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Abstract 
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The  PILOT  Process  Integrated  Model  can  produce  energy /economic  scenarios 
for  time  periods  of  up  to  100  years  by  aggregating  several  5  year  time 
periods  into  one.  This  report  presents  modification  to  an  existing  aggrega¬ 
tion  method  that  utilize  the  special  structure  of  the  Consumers  Energy 
Service  Model  (CESM)  and  the  Industrial  Energy  Service  Model  (IESM)  and 
reduce  aggregation  bias  in  these  portions  of  the  PPIM. 
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I .  INTRODUCTION 


The  Stanford  PILOT  Energy/Economic  model  provides  projections  of 
energy  production  and  use  and  of  economic  growth  in  the  U.S.  over  a  40 
year  span,  1973-2012,  divided  into  eight  5  year  periods.  A  longer  time 
horizon  of  say,  100  years,  would  enable  the  PILOT  model  to  address  pol¬ 
icy  decisions  whose  effects  may  not  be  felt  till  well  past  the  turn  of 
the  century.  The  decisions  surrounding  plutonium  recycling  and  the  fast 
breeder  reactor  fall  in  such  a  category,  and  have  been  studied  using  a 
longer  time  horizon  by  Avi-Itzhak  and  Connolly  [ l]  .  A  longer  time  hori¬ 
zon  for  the  PILOT  model  is  also  useful  for  determining  terminal  capital 
stocks  and  other  end  conditions  for  the  shorter  40  year  time  horizon. 

However,  it  is  not  practical  computationally  to  run  a  scenario  of 
20  periods  of  5  years  each.  To  overcome  this  difficulty,  a  computer 
program  has  been  developed  and  tested  to  aggregate  the  20  time  periods 
into  a  smaller  number  of  planning  periods  of  variable  length,  yielding  a 
LP  matrix  the  size  of  the  40-year  PILOT  model  [2] .  The  length  of  any 
time  period  in  the  aggregated  matrix  is  some  multiple  of  5  years. 

The  aggregation  scheme  consists  of  two  steps. 

°  Aggregating  variables  (by  adding  column  coefficients). 

0  Aggregating  equations  (by  adding  row  coefficients). 

It  has  been  shown  that  the  solution  yielded  by  the  reduced  problem  is 
consistent  with  that  of  the  original  problem  but  not  necessarily  conver¬ 
sely  [3]  . 

The  aggregation  scheme  substitutes  one  planning  period  for  several 
periods  of  the  original  matrix.  The  activity  levels  in  the  aggregated 


periods  are  intended  to  be  representative  of  similar  activities  in  the 
several  unaggregated  periods. 

Since  the  date  this  scheme  was  first  implemented,  some  modifica¬ 
tions  to  the  PILOT  model  have  been  made.  A  Consumers  Energy  Service 
Model  (CESM)  [4]  and  an  Industrial  Energy  Service  Model  (IESM)  [5l  have 
been  added  to  the  PILOT  model,  forming  the  PILOT  Process  Integrated 
Model.  These  two  submodels  utilize  energy  facility  capital  stock  ac¬ 
counting  different  from  that  in  the  main  model.  This  capital  stock 
modeling  leads  to  LP  columns  with  exponentially  declining  coefficients 
in  later  periods,  and  suggests  that  a  somewhat  different  aggregation 
scheme  may  help  decrease  aggregation  bias  in  the  CESM  and  IESM  portion 
of  the  integrated  model.  The  CESM  and  IESM  together  contain  approxi¬ 
mately  320  rows  and  1000  columns  of  the  total  1300  rows  and  2700  columns 
in  an  eight-period  PILOT  matrix.  An  aggregation  scheme  that  can  reduce 
bias  in  this  fraction  of  the  total  model  should  yield  improved  results 
for  the  whole  as  well. 
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II.  MODIFICATION  OF  THE  VARIABLE  TIME  MODEL 


I 


A.  CESM  and  IESM  models 

Many  CESM  and  IESM  variables  refer  to  the  total  amount  of  capa¬ 
cities  installed  in  the  current  period.  Fractions  of  these  capacities 
survive  to  be  used  in  latter  periods.  The  capacities  depreciate  accord¬ 
ing  to  an  exponential  curve,  for  example,  if  the  coefficient  of  a  column 
•  ••  •  •  • 

in  period  t  is  1,  the  coefficient  in  period  t  +  k  is  d  where  0  <  d  <  1 
is  the  survival  fraction  from  one  5-year  period  to  the  next. 

Consider  the  example  of  an  energy  technology  T  installed  in  period 
1.  Suppose  periods  2,  3  and  4  are  aggregated  to  a  single  15  year  period. 
Since  midpoints  of  the  planning  periods  are  used  as  representative  dates, 

the  contribution  of  technology  T  in  the  aggregated  period  should  be  given 

.  .  .  2 
by  a  survival  fraction  based  on  2  full  time  periods,  or  d  .  A  scheme  of 

choosing  the  coefficient  according  to  an  arithmetic  average  would  give  a 

2  3 

coefficient  equal  to  d  +  d  +  d  .  If  the  geometric  mean  is  used,  the 

3 

3/  2  3  2 

new  coefficient  is  V  d  "  d  •  d  *  d  . 

Any  aggregation  scheme  introduces  a  bias.  But  a  scheme  that  more 

accurately  approximates  the  "true"  coefficient  is  desirable.  Therefore 

we  will  use  an  aggregation  scheme  that  computes  the  geometric  mean  of 

original  coefficients  for  those  columns  in  the  CESM  and  IESM  portion 

that  display  the  exponentially  declining  coefficients. 


B. 


Geometric  aggregation  scheme 
An  outline  of  the  geometric  scheme  follows. 

1.  Take  the  geometric  mean  of  the  column's  coefficients  across  all 
rows  of  the  periods  to  be  aggregated. 

2.  Add  coefficients  across  columns  of  the  periods  to  be  aggregated. 
Columns  in  the  CESM  and  IESM  other  than  these  capacity  columns  are  ag¬ 
gregated  in  the  standard  aggregation  scheme. 

The  following  is  an  example  of  aggregation  of  3  periods  with  a  rep¬ 
resentative  survival  rate  of  0.6  and  an  increasing  service  need. 


x.  =  values  are  total  capacity  installed. 

y.  =  values  are  service  needed. 

assumed  y1  =  y,  y2  =  2y,  y3  =  3y. 

Without  aggregation,  the  solutions  are 

*1  "  y.  x2  =  *-*y.  *3  ■  i-8y 

A  representative  value,  the  mean  of  Xp  x^,  is  x  =  1.4y  for  the  new 
period  1. 

Using  the  geometric  aggregation  scheme,  the  single  resulting  equation 
and  its  solution  are: 


4 


1.38 


4. 35x  =  6y  ,  x  = 
g 

Using  the  arithmetic  aggregation  scheme,  the  single  resulting  equation 
and  its  solution  are 


4.56x  =  6y  ,  x  =1.32 
J  a 

This  result  illustrates  that  geometric  aggregation  gives  results  closer 
to  the  original  5  year  period  model. 

C.  Modification  of  variable  time  model  program 

The  arithemtic  aggregation  scheme  is  implemented  in  a  FORTRAN 
program  that  processes  the  MPS  -  format  LP  matrix  listing.  As  a  pro¬ 
gramming  convenience  in  the  first  implementation,  only  additions  are 
made  and  the  coefficients  in  arithemtic  aggregation  are  not  divided  by 
the  number  of  periods  in  the  aggregation.  Thus  two  identical  rows  would 
appear  aggregated  as  one  row,  but  with  all  coefficients  multiplied  by 
two.  The  geometric  aggregation  scheme  must  therefore  multiply  the  geo¬ 
metric  mean  by  the  number  of  periods  to  maintain  correct  linkage  and 
consistency  with  the  rest  of  the  model. 

The  aggregation  takes  place  in  two  stages,  first  across  rows  then 
across  columns.  Modification  to  the  existing  program  is  done  in  two 
parts.  The  first  is  shown  in  Figure  1  where  row  aggregation  in  the  main 
program  is  done.  The  second  is  shown  in  Figure  2  where  column  aggregation 
is  done  in  the  subroutine  UPDATE.  To  distinguish  the  two  aggregation 
modes,  marker  cards  reading  "*ARITH"  and  "*GEOM"  are  needed  in  the  input 
deck.  If  no  marker  appear,  the  program  defaults  to  arithmetic  aggregation 
for  the  entire  matrix. 
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Figure  1 


Row  aggregation  in  the  MAIN  program 
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Figure  2 

Column  aggregation  in  the  subroutine  UPDATE 
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III.  Test  Run  of  Modified  Variable  Time  Model 

A.  Test  run 

Test  run  of  the  geometric  aggregation  scheme  was  made  and  com¬ 
pared  with  arithmetic  aggregation  results.  To  minimize  computational 
costs  the  development  and  testing  was  done  on  a  eight  period  40  year 
model  which  contained  the  CESM  but  not  the  IESM.  The  eight  periods  were 
aggregated  to  five  planning  periods  covering  the  same  horizon.  The 
qualitative  results  presented  here  will  generalize  both  to  a  longer  time 
horizons  and  to  a  model  containing  the  IESM. 

The  test  runs  were  made  with  an  unaggregated  8  period  "Longdeck" 
and  two  aggregated  5  period  models:  "Short  G",  derived  using  the  modi¬ 
fied  geometric  aggregation  scheme  and  "Short  A",  derived  using  only  the 
arithmetic  aggregation.  A  single  aggregation  mapping  of  periods  from 
Longdeck  to  either  aggregated  matrix  was  tested.  The  mapping  1—2—3— 1— 1 


yields  5  periods  in  the  short  deck  with  lengths  5,  10,  15,  5  and  5.  For 
example  periods  2  and  3  from  longdeck  become  period  2  in  either  short  A 
or  short  G.  No  aggregation  is  done  for  either  the  first  or  last  periods 
in  order  that  the  aggregated  matrices  have  several  periods  with  identical 
coefficients  as  the  original. 

B.  Comparison  of  results 

The  observed  objective  function  values  were 


Longdeck 

Short  G 

Short  A 

5745.16663 

5701.71558 

5654.43644 

FT'  "" 

I 

Note  that  the  objective  value  of  Short  G  is  closer  than  that  of  Short  A 
to  the  value  of  the  unaggregated  Longdeck. 

The  comparison  of  objective  values  alone  is  not  sufficient  to  indi¬ 
cate  that  Short  G  yields  better  results.  We  will  also  present  compari¬ 
son  of  more  detailed  model  activities.  Gross  National  Product  and  Total 
Primary  Energy  Consumption  are  activities  from  the  main  portion  of  the 
model.  Their  aggregation  is  done  using  an  arithmetic  scheme  in  both  the 
original  and  modified  variable  time  programs.  The  results  given  in  Table 
1  show  that  differences  are  small  between  aggregation  schemes  for  these 
two  variables.  However,  we  note  that  the  numerical  vaules  from  the  mod¬ 
ified  program  are  larger  than  the  those  from  the  original  program. 

The  modified  aggregation  scheme  focused  on  the  CESM  portion  of  the 
integrated  PILOT  model.  The  CESM  models  uses  four  energy  services; 
space  heat,  other  thermal  residential,  air  conditioning,  and  automobile 
drive.  A  total  of  55  energy  service  technologies  provide  these  four 
services.  Due  to  the  structure  of  the  CESM  we  cannot  expect  the  LP  solu¬ 
tion  of  an  aggregated  model  to  agree  with  the  unaggregated  solution  in 
all  55  technologies  for  every  period.  However,  the  totals  across  energy 
service  types  demonstrate  that  a  geometric  aggregation  scheme  for  CESM 
capital  stock  variables  yields  solution  closer  to  the  unaggregated  values. 
Tables  2  and  3  present  the  solution  values  for  all  technologies  in  two 
of  the  four  CESM  energy  services.  The  survival  rates  are  0.918  for  Space 
Heat  and  0.59  for  Other  Thermal. 
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Table 


Table  2 

Space  Heat  Comparison 


Longdeck  3.446 

3.6235 

4.834 

5.717 

6.379 

Total 

3.  718 

3.813 

4.297 

4.907 

EBBEK15S 

3.674 

3.624 

4.327 

5.157 
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Table  3 

Other  Thermal  Comparison 


old  . 

X\^~-~~C^j>eriod 

N.  \new 
x  \neriod  h 

1 

2 

3 

4 

5 

6 

7 

8 

Energy  Xus ed^\ 
Service  x^scheme'^"^ 

1 

2 

3 

4 

5 

Longdeck 

.350 

.132 

EWO 

Short  G 

.350 

.081 

Short  A 

.350 

.081 

L 

_ 

EW1 

S  G 

.609 

.212 

.125 

S  A 

.511 

.178 

.105 

L 

.706 

EW2 

S  G 

S  A 

_ 

L 

.460 

.867 

1.074 

1.188 

1.363 

.804 

EW3 

S  G 

.653 

1.075 

S  A 

_ _ _ 

.715 

1.142 

L 

.741 

.279 

GWO 

S  G 

.741 

.172 

S  A 

.741 

_ dZ2 _ 

L 

.168 

.786 

.625 

.369 

.218 

.128 

.076 

.045 

GW  3 

S  G 

.168 

.833 

.222 

.077 

.046 

S  A 

.168 

.802 

.214 

.075 

.044 

L 

.150 

.088 

.052 

.031 

.018 

.011 

SW1 

S  G 

.035 

.271 

.094 

.056 

S  A 

.030 

.235 

.082 

.048 

L 

.013 

.063 

.187 

.321 

.406 

.469 

.567 

.668 

SW2 

S  G 

.013 

.131 

.035 

.292 

.500 

S  A 

.013 

.131 

.035 

.310 

.523 

L 

1.271 

1.342 

1.736 

2.624 

1.528 

Total 

S  G 

1.271 

1.252 

1.137 

1.328 

1.800 

S  A 

■JL271, 

1.216 

0.995 

1.360 

1.862 

t 


Note  that  solution  values  from  the  geometric  aggregation  are  greater  than 
the  those  from  the  arithmetic  aggregation.  This  is  a  general  result  and 
can  be  stated  as  the  following  proposition. 

Proposition 


>  xa  where  x^  has  exponentially 

declining  coefficients. 

Proof  )  For  0  <  d  <  1,  the  geometric  mean  of  the  powers  of  d  <_ 
arithmetic  mean,  i.e. 


i-1 


Therefore,  the  new  coefficients  of  geometrically  aggregated  periods 
are  less  than  or  equal  to  the  corresponding  coefficients  in  arith¬ 
metically  aggregated  periods. 

The  energy  service  demanded  in  PILOT  is  influenced  indirectly  by 
the  total  investments  in  energy  facility  capital  stocks,  but  this  influ¬ 
ence  is  quite  small  and  not  large  enough  to  overcome  the  difference  in 
coefficient  values  between  the  aggregation  schemes.  Therefore  the  inte¬ 
grated  solutions  of  the  aggregated  models  will  exhibit  similar  values 
for  GNP  and  other  macroeconomic  values  and  larger  values  for  total  CESM 
capital  stocks  in  the  modified  aggregation. 

C.  Conclusion 

Any  aggregation  scheme  introduces  some  aggregation  bias,  which  indi¬ 
cates  information  is  lost.  For  the  PILOT  CESM  and  IESM,  this  aggregation 
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bias  can  be  reduced  by  using  a  scheme  based  on  a  geometric  mean  of 
coefficients.  The  numerical  results  and  the  proposition  above  show  that 
CESM  and  IESM  values  from  a  geometric  aggregation  are  larger  in  absolute 
values  than  those  from  an  arithmetic  scheme. 

The  capital  stock  structure  of  the  CESM  embodies  information  of  two 
types.  Stocks  are  installed  that  provide  energy  service  demand  within  a 
single  time  period  and  that  replace  earlier  vintages  of  capital  stock 
that  have  depreciated.  This  inter-tempcral  depreciation  relation  is 
destroyed  by  aggregation.  By  using  a  geometric  aggregation  scheme,  so¬ 
lution  values  more  closely  approximate  the  representative  values  from  the 
unaggregated  periods,  thus  recapturing  some  lost  information  and  reducing 
aggregation  bias.  Even  though  numerical  results  are  presented  for  a 
short  time  horizon  in  a  model  containing  only  the  CESM,  the  qualitative 
results  are  expected  to  hold  for  longer  time  horizons  and  for  an  inte¬ 
grated  model  containing  the  IESM  as  well. 
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39.  //* 

40.  //  EXEC  WATFIV, FOR TVER-NEW 

41.  //FT06F00I  DO  SYSOUT=A 

42.  //FT0SF001  DD  UNIT=0ISK ,OSN-WYL.WJ .««* . LONGDECK ,VOL=SER=WORK03, 

43.  //  DISP=SHR 

44.  //FT09F001  DD  UNIT=DISK,OSN-WYL.WJ.««*. SHORT, VOL=SER=WORK03, 

45.  //  SPACE =( TRK ,(200.20),RLSE) ,DISP=( NEW, KEEP) , 

46.  //  DCB-I RECFM=FB>  LRECL=80 ,BLKSIZE=31 20 ) 

47.  //GO.SYSIN  DD  » 

48.  ♦ WATFIV 


49.  CHARACTER# 1  PRNAME! 100,2) .TYPIN! 4 ) >TYPE( 4 ) .NAME INI S ) .NEUNAME!  8 ) , 

50.  1  ROWNAME ( 8 ) , COLNAME ( 6 ) >  CNAME ( 8 )  >  RNAME (2.8) 

51.  CHARACTER#!  DIGIT! 1 0 ) .BLANK, ASTERSK > 

52.  1  C0LI4),RHS(4),BDUNDS(4),ENDATA(4),GEM!4),ARI(4), 

55.  2  FR(2),FX(2),UP(2)>LO(2),MI(2) 

54.  CHARACTER«80  CARD 

55.  INTEGER  PBLANK , LISTINl 20 ) , INOUT1 20 ) 

56.  LOGICAL  PASS! .ARITH.GEOM.MINUS1 .TRUE, FALSE 

57.  C— 

58.  C—  (THE  DIMENSION  OF  NAMETAB  AND  VALUTAB  SHOULD  EXCEED  THE  MAXIMUM 

59.  C -  NUMBER  OF  MPS  ROM  ENTRIES  ANTICIPATED  IN  ANY  COLUMN,  AFTER 

60.  C—  AGGREGATION.  ANY  REDIMENSIONING  MUST  BE  CARRIED  OUT  IN  SUBROUTINES 

61.  C—  UPDATE  AND  COLOUT  AS  WELL) 

62.  C - 

65.  CHARACTER#!  NAMETABI 1 00 ,8 ) 

64.  DIMENSION  VALUTABI 1 00 ) .RVALUI 2 ) 

65 .  COMMON/BLOCK  1 /NPRIN , NPROUT , INOUT , PRNAME 

66 .  COMMON/B  LOCK  2/COLNAME , NAMETAB .VALUTAB, MAXENT 

67.  C - 

68.  C - 

69.  C - 

70.  C - 

71 .  C  INITIALIZE  CONSTANTS  AND  READ  AGGREGATION  SCHEME 

72.  C— 

73.  C—  INITIALIZE  ARRAY  OIGIT  TO  CHARACTER  EQUIVALENTS  OF  THE  10  DIGITS 

74.  C— 

75.  DATA  DIGIT( 1 ) .DIGIT! 2 ) , DIGIT! 3 ) .DIGIT! 4 J/,0,,l1,,,2,*,3'/ 

76.  DATA  DIGIT! 5 ) .DIGIT! 6 ) .DIGIT! 7 ) .DIGIT! 8)/'4',,5,,'6',,7'/ 

77.  OATA  DIGIT! 9 1 , OIGIT! !0 )/’8 ' > ’ 9 ’/ 

76  C - 

79.  c—  INITIALIZE  COL, RHS, BOUNDS,  AND  ENDATA  (MPS  SEGMENT  NAMES) 

80.  C— 

81.  OATA  COL! 1 ) ,COL( 2  ) , COL! 3 ) ,C0L(4 )/ 'C 1 .'O'.'L'.'U'/ 

82.  OATA  RHS!  1  )  ,RHS(  2  )  ,RHS(  3 )  ,RH5(  4  )/‘R  •  ,'H'  ,'S'  ,' 

83.  OATA  BOUNDS!  I  )  .BOUNDS!  2  ),  BOUNDS!  3  ),  BOUNDS!  4  )/  ’B 1 ,  'O'  ,  'U'.’NV 

84 .  OATA  ENOATA! 1 ) , ENOAT A! 2 ) , END AT At  3 ) .ENDATA14 )/' E* .'N'.'D'.'A'/ 

84.1  DATA  GEM!  1  )  .GEM!  2  )  ,GEM(  3) ,GEM(4 >/ '#'  ,  'G'  ,  'E'  ,  '07 

84.2  OATA  ARI!  1  )  »ARI(  2 )  ,ARI(  3)  ,ARI(4 )/'«'  .'A'.'R'.’IV 

85.  C— 

86.  C—  INITIALIZE  FR.FX.UP.LO  AND  MI  (BOUND  TYPE  NAMES) 

87.  C  — 

88.  DATA  FR( 1 ) ,FR( 2 ) »FX( 1 ) ,FX( Sl/'F'.'R’.'F'.'X'/ 

89.  OATA  UP!  1  )  ,UP(  2  ) ,  10!  1 ) ,LO( 2 )/'U* » 'P' » ' L* » *0'/ 

90.  OATA  MI! 1 ) ,MI! 2 )/'M' , ‘ I  V 

91  .  C - 

92 .  C—  INITIALIZE  BLANK  AND  ASTERSK  (SINGLE  CHARACTERS) 

93.  C— 

94.  DATA  BLANK, ASTERSK/'  ',•#’/ 

95.  C— 

96.  C—  INITIALIZE  TRUE  AND  FALSE  (LOGICALS) 

97.  C— 

98. 


DATA  TRUE, FALSE/. TRUE. ..FALSE./ 


99. 

c— 

100. 

c — 

101  . 

c — 

102. 

c— 

103. 

c— 

104. 

c— 

105. 

106. 

107. 

c— 

106. 

c— 

109. 

c— 

110. 

c— 

111. 

112. 

113. 

114. 

c — 

115. 

c— 

1 16. 

c— 

117. 

c— 

116. 

c— 

119. 

c— 

120. 

c— 

121  . 

20 

122. 

c — 

123. 

c— 

124. 

c— 

125. 

126. 

c— 

127. 

c— 

126. 

c— 

129. 

c  — 

130. 

131  . 

132. 

c— 

133. 

c — 

134. 

c— 

135. 

c— 

136. 

c— 

137. 

138. 

900 

139. 

c— 

140. 

c— 

141  . 

c— 

142. 

143. 

902 

144. 

c— 

145. 

c— 

146. 

c— 

147. 

c— 

t48. 

c— 

149. 

c— 

150. 

c — 

INITIALIZE  2-DIM.  ARRAY,  PRNAME,  TO  TWO  CHARACTER  EQUIVALENTS 
OF  EACH  POSSIBLE  PERIOD  NUMBER  II. E.  CO'.'O’)  TO  C,9,,,9*»  ) 
LOOP  OVER  I  TO  SELECT  FIRST  DIGIT 
J  TO  SELECT  SECOND  DIGIT 

DO  20  1=1 >10 
DO  20  J=1,10 

(N-TH  LEVEL  OF  ARRAY  PRNAME  CORRESPONDS  TO  N“TH  POSITION 
IN  THE  SEQUENCE  00,01  ,02,03 . 99  ) 

N  =  (1-1  1*10  ♦  J 
PRNAMEl N, 1 )  =  DIGIT(I) 

PRNAME! N, 2 )  =  DIGIT! J ) 

EXAMPLES  - 

09  IS  IN  10-TH  POSITION 
N=10  RESULTS  FROM  I=1,J=10 
1=1  SELECTS  OIGIT  'O' 

J=10  SELECTS  OIGIT  '9' 

CONTINUE 

INITIALIZE  MAXPR  (MAXIMUM  NUMBER  OF  PERIODS  IN  OUTPUT  MODEL) 
MAXPR  =20 

INITIALIZE  MAXENT  (MAXIMUM  NUMBER  OF  ENTRIES  IN  OUTPUT  TABLES) 
AND  LASTIX  (INDEX  OF  LAST  ENTRY  IN  OUTPUT  TABLES) 

MAXENT  =  100 
LASTIX  =  0 

(TWO  INPUT  CAROS  ARE  LOCATED  AT  THE  END  OF  THIS  DECK) 

READ  AND  IGNORE  DUMMY  CARO  (USED  ONLY  FOR  IDENTIFYING  FIELDS 

OF  NEXT  CARO  WHEN  KEYING  IN  DATA) 

READ  (5,900)  CARO 
FORMAT  (ABO) 

READ  AGGREGATION  SCHEME  CARD 

READ  (5,902)  LISTIN 
FOR MAT( 2013) 

(LISTIN  -  THE  I-TH  NUMBER  IN  LISTIN  IS  THE  NUMBER  OF  PERIODS 
FROM  THE  INPUT  MODEL  TO  BE  AGGREGATED  WHEN  FORMING 
THE  I-TH  PERIOD  OF  THE  OUTPUT  MOOEL) 

COMPUTE  NPROUT  (NUMBER  OF  PERIOOS  IN  OUTPUT  MOOEL 
=  NUMBER  OF  NONZEROS  IN  LISTIN) 


10  IS  IN  11 -TH  POSITION 
N=1 1  RESULTS  FROM  1=2, J=1 
1=2  SELECTS  DIGIT  *1 ' 

J=1  SELECTS  DIGIT  'O' 


c— 


151  . 

152. 

153. 

154. 

155. 

156. 

157. 

158. 

159. 

160. 
161  . 
162. 

163. 

164. 

165. 

166. 

167. 

168. 

169. 

170. 
171  . 

172. 

173. 

174. 

175. 

176. 

177. 

178. 

179. 

180. 
181  . 
182. 

183. 

184. 

185. 

186. 
187. 
168. 

189. 

190. 
191  . 

192. 

193. 

194. 

195. 

196. 

197. 

198. 

199. 

200. 


00  40  N=1 >  MAX PR 

IF  1 LISTINIHI.EO.O)  GO  TO  50 
40  CONTINUE 

C — 

C -  NO  ZEROS  IN  LISTIN. 

C  — 

N  =  MAXPR  ♦  1 

c— 

c—  N  EQUALS  NUMBER  OF  NOHZEROS  IN  LISTIN  PLUS  ONE. 

C — 

50  NPROUT  =  N  -  1 

IF  ( NPROUT. EQ.O)  STOP 

C— 

c—  COMPUTE  INOUT  (I*TH  ELEMENT  OF  ARRAY  INOUT  IS  THE  PERIOD 
C—  NUMBER  OF  THE  LAST  PERIOD  OF  THE  INPUT  MODEL  TO  BE 
C—  AGGREGATED  INTO  THE  I-TH  PERIOD  OF  THE  OUTPUT  MODEL) 

C— 

LAST PR  =  0 
DO  60  1=1 .MAXPR 

LAST PR  =  LASTPR  ♦  LISTIN(I) 

INOUT! I)  =  LASTPR 
60  CONTINUE 

c— 

c—  SAVE  NPRIN  (NUMBER  OF  PERIODS  IN  THE  INPUT  MODEL) 

c— - 

NPRIN  =  INOUT! NPROUT) 

c— 

c—  COMMON  BLOCK1  IS  NON  WELL-DEFINED. 

C— 

c— 

c—  PRINT  OUT  AGGREGATION  SCHEME 
C--- 

NRITE  >6,991 ) 

991  FORMAT  C 1H  INPUT  CARDS  ->  ) 

WRITE  (6,992)  CARD 

992  FORMAT  (1H  ,A80) 

WRITE  (6,993)  LISTIN 

993  FORMAT  ( 1H  ,2013,/) 

WRITE  (6,994) 

994  FORMAT  ( 1H  .'LIST  OF  LAST  INPUT  PERIOD  NUMBER  CORRESPONDING" 

1  >  TO  EACH  OUTPUT  PERIOD  NUMBER  -',/) 

WRITE  (6,995)  CARD 

995  FORMAT  (1H  , 'OUTPUT  PERIOD  NUMBER', A60) 

WRITE  (6,996)  ( INOUT ( I ) ,1=1 .NPROUT ) 

996  FORMAT  (1H  , 'INPUT  PERIOD  NUMBER  ',2013) 

WRITE  (6,997) 

997  FORMAT  (1  HI, 'LIST  OF  WARNING  MESSAGES  -  SEE  COMMENTS  WITHIN 

1  'PROGRAM  FOR  DEFAULT  ACTION',/) 

c— 


203. 

C  SWITCH  TO  INPUT  MODEL  FILE 

204. 

c — 

205. 

c — 

COPY  ■•NAME"  CARO  AND  "ROWS"  CARO  TO  OUTPUT  FILE 

206. 

c — 

207. 

DO  80  1=1 ,2 

203. 

READ  (8,900)  CARD 

204. 

WRITE  (9,900)  CARD 

210. 

80 

CONTINUE 

211. 

c— 

212. 

c — 

213. 

c — 

214. 

c — 

215. 

c — 

216. 

C  ROWS  SEGMENT  BEGINS 

217. 

c— 

218. 

c— 

BEGIN  ROWS  CARD  CYCLE  -  ONE  PASS  FOR  EACH  CARD  READ 

219. 

c— 

220. 

c— 

SET  PASS1  (FIRST  PASS  INDICATOR)  ON  OR  OFF 

221 . 

c-— 

222. 

PASS1  =  TRUE 

223. 

CO  TO  105 

224. 

100 

PASS)  =  FALSE 

225. 

c— 

226. 

c— 

REAO  A  CARD  USING  ROW  CAPO  FORMAT 

227. 

c — 

228. 

1 05 

REAO  (8,910)  TYPIN.NAMEIN 

229. 

910 

FORMAT  (4A1.8A1) 

230. 

C  — 

231 . 

c— 

(TYPIN  -  ROW  TYPE) 

232. 

c-~ 

(NAME IN  -  ROW  NAME) 

233. 

C-" 

234. 

C-  — 

SKIP  COMMENT  CARDS 

235. 

c— 

236. 

IF  ( TYPIN1 1 ) . EQ . ASTERSK )  GO  TO  105 

237. 

c— 

238. 

c™ 

REFORM  ROW  NAME  BY  CALLING  SUBROUTINE  RENAME 

239. 

c— 

240. 

CALL  RENAME ( NAME IN .NEWNAME , INEWPR ,NBLANK ) 

241  . 

c— 

242. 

c— 

(NEWNAME  -  NAME  OF  INPUT  ROW  AS  IT  IS  TO  APPEAR  ON  OUTPUT) 

243. 

c— 

( MB LANK  -  NUMBER  OF  BLANKS  AT  END  OF  NEWNAME) 

244. 

c — 

245. 

c — 

ON  FIRST  PASS,  BRANCH  TO  "NEW  ROW  NAME" 

246. 

c — 

247. 

IF  ( PASS1 )  GO  TO  1 70 

248. 

c— 

249. 

c— 

(ASSUME  MPS  INPUT  FILE  SORTED  SO  THAT  ROW  NAMES  WITH 

THE 

250. 

c-— 

SAME  ROOT  ARE  GROUPED  TOGETHER  IN  ASCENDING  ORDER  OF  PERIOD 

251  . 

c— 

NUMBER.  CONSEQUENTLY,  AFTER  NAMES  ARE  REFORMED  THE  1 

ROWS 

252. 

c— 

WHICH  ARE  TO  BE  AGGREGATED  WILL  BE  GROUPED  TOGETHER 

UNDER 

253. 

c— 

A  COMMON  (OUTPUT)  ROW  NAME) 

254. 

c— 

i  .ii'ri 


■s  •* 


255. 

c — 

COMPARE  NEWNAHE  WITH  ROWHAME  (THE  NEWNAME  OF  THE  PREVIOUS  CARO) 

256. 

c— 

(TO  SAVE  TIME,  CONSIDER  ONLY  NONOLANK  CHARACTERS  OF  NEWNAME ) 

257. 

c— 

258. 

NONBLK  =  8  -  NBLANK 

259. 

00  110  1=1, NONBLK 

260. 

c — 

261  . 

c — 

IF  NO  MATCH,  BRANCH  TO  "OUTPUT  PREVIOUS  ROW" 

262. 

c — 

265. 

IF  (NEUNAME(I).NE.ROWNAME(I))  60  TO  150 

264. 

no 

CONTINUE 

265. 

c— 

266. 

c — 

NAMES  MATCH.  (ROW  ID  FOR  NEWNAME  HAS  ALREADY  BEEN  SET  UP) 

267. 

c — 

PRINT  WARNING  IF  TYPE  DIFFERS  FROM  TYPE  OF  PREVIOUS  CARD, THEN 

268. 

c — 

60  READ  A  NEW  ROWS  CARD 

269. 

c— 

270. 

DO  120  1=1 ,2 

271  . 

IF  (TYPIN(I).NE.TYPE(D)  GO  TO  130 

272. 

120 

CONTINUE 

273. 

GO  TO  100 

274. 

130 

WRITE  (6,950)  TYPIN.NAMEIN.TYPE .ROWNAME 

275. 

950 

FORMAT  (1H  ,'ROW  ID  INPUT  AS  ,,4A1,8A1,*  WILL  BE  OUTPUT  AS  ’, 

276. 

1  4A 1 , 8A 1 , '  **  TYPE  CHANGE’) 

277. 

GO  TO  100 

278. 

c— 

279. 

c — 

OUTPUT  PREVIOUS  ROW  10  USING  ROW  CARD  FORMAT 

280. 

c — 

281  . 

150 

WRITE  (9,910)  TYPE, ROWNAME 

282. 

C — ” 

283. 

C-— 

IF  NAMES  OIO  NOT  MATCH  BECAUSE  NEW  CARD  WAS  "COLUMNS"  CARD 

284. 

c— 

BRANCH  TO  "COLUMN  SEGMENT  BEGINS" 

285. 

c— 

286. 

DO  160  1=1,4 

287. 

c - 

288. 

c— 

IF  TYPE  NOT  EQUAL  TO  ’C ’ , ’0* , ’ L’ , ’U’ ,  BRANCH  TO  "NEW  ROW” 

289. 

c— 

290. 

IF  (TYPIN(I).NE.COL(I))  GO  TO  170 

291  . 

160 

CONTINUE 

292. 

GO  TO  200 

293. 

c— 

294. 

c— 

NEW  ROW  NAME  ENCOUNTERED. 

295. 

c— 

296. 

c— 

RESET  OUTPUT  BUFFERS  *  SAVE  NEWNAME  AS  ROWNAME 

297. 

c— 

-  SAVE  TYPIN  AS  TYPE 

298. 

c — 

299. 

170 

DO  180  1=1 ,8 

300. 

ROWNAME ( I )  =  NEWNAME ( I ) 

301  . 

180 

CONTINUE 

302. 

DO  190  1=1,4 

303. 

TYPE! I)  =  TYPIN(I) 

304. 

190 

CONTINUE 

305. 

c— - 

306. 

c — 

GO  REAO  A  NEW  ROWS  CARD 

307. 

c— 

308. 

GO  TO  100 

309. 

c— 

310. 

c— 

31  1  . 

c — 

312. 

c — 

313. 

c — 

314. 

C  COLUMN  SEGMENT  BEGINS 

315. 

c— 

316. 

c— 

OUTPUT  "COLUMNS"  CARD 

317. 

c — 

318. 

200 

WRITE  (9,912) 

319. 

912 

FORMAT  ('COLUMNS') 

319.1 

COUNT: 1 

319.3 

ARITH:TRUE 

319.31 

GEOM=FALS£ 

319.4 

MINUS! :FALSE 

320. 

c — 

321. 

c — 

BEGIN  COLUMN  CARO  CYCLE  -  ONE  PASS  FOR  EACH  CARD  READ 

322. 

c — 

323. 

c — 

SET  PASS1  (FIRST  PASS  INDICATOR)  ON  OR  OFF 

324. 

c — 

325. 

PASS1  =  TRUE 

326. 

GO  TO  210 

327. 

205 

PASS1  =  FALSE 

327.1 

GO  TO  210 

328. 

c— 

329. 

c— 

READ  A  CARO  USING  COLUMN  CARD  FORMAT 

330. 

c — 

330.1 

207 

00  209  J=2,4 

330.2 

IF  ( TYPIN( J 1 .N.E.ARI1 J> )  GO  TO  210 

330.3 

209 

CONTINUE 

330.4 

GEOM:FALSE 

331  . 

210 

READ  (8,914)  TYPIN.CNAME , ( RNAME1 1 ,1 ) ,1=1 .8 ) .RVALU1 1 ) , 

332. 

1  <  RNAMEI 2, J ) > J=1 ,6) ,RVALU( 2 ) 

333. 

914 

FOPMAT  (4A1 ,8A1 ,2X,2(8A1 > 2X , F 1 2 . 6 , 3X ) ) 

334. 

c— 

335. 

c — 

(TYPIN  -  BLANK) 

336. 

c — 

( CNAME  -  COLUMN  NAME) 

337. 

c— 

(RNAMEI 1)  AND  (2)  -  ROW  NAMES  OF  MATRIX  ENTRIES) 

338. 

c — 

(RVALU(I)  AND  (2)  -  MATRIX  ENTRIES) 

339. 

c — 

340. 

c — 

SKIP  COMMENT  CARDS 

341 . 

c — 

342. 

IF  ( TYPIN< 1  )  .NE . ASTERSK )  GO  TO  215 

342.1 

DO  229  J=2 ,4 

342.2 

IF  (TYPIN(J).NE.GEMl J))  GO  TO  207 

342.3 

229 

CONTINUE 

342.4 

GEOM=TRUE 

342.6 

GO  TO  210 

343. 

c— 

344. 

c — 

REFORM  COLUMN  NAME  BY  CALLING  SUBROUTINE  RENAME 

345. 

c— 

346. 

215 

347. 

c— 

348. 

c — 

349. 

c — 

350. 

c — 

351 . 

c— 

352. 

c— 

353. 

354. 

c— 

355. 

c— 

356. 

c— 

357. 

c— 

358. 

c — 

359. 

c — 

360. 

c — 

361 . 

C” 

362. 

c— 

363. 

c— 

364. 

365. 

c— 

366. 

c— 

367. 

c— 

368. 

c— 

369. 

370. 

371  . 

c— 

372. 

c— 

373. 

c — 

374. 

375. 

224 

376. 

c — 

377. 

C” 

378. 

c-- 

379. 

c— 

380. 

c— 

381  . 

382. 

c— 

383. 

c— 

384. 

c— 

385. 

c— 

386. 

C" 

387. 

230 

387.1 

388. 

c— 

389. 

c— 

390. 

C" 

391  . 

c— 

392. 

c — 

393. 

c — 

394. 

c — 

395. 

c — 

CALL  RENAME ( CNAME . NEMNAME  > INEHPR , N8LANK ) 

(NEMNAME  -  NAME  OF  INPUT  COLUMN  AS  IT  IS  TO  APPEAR  ON  OUTPUT) 

( NS LANK  -  NUMBER  OF  BLANKS  ON  ENO  OF  NEMNAME) 

ON  FIRST  PASS,  BRANCH  TO  "NEW  COLUMN" 

IF  ( PASS) )  GO  TO  250 

(ASSUME  MPS  INPUT  FILE  IS  SORTED  SO  THAT  COLUMN  NAMES  MITH 
THE  SAME  ROOT  ARE  GROUPED  TOGETHER  IN  ASCENDING  ORDER  OF 
PERIOD  NUMBER.  CONSEQUENTLY ,  AFTER  NAMES  HAVE  BEEN  REFORMED 
THE  COLUMNS  MHICH  ARE  TO  BE  AGGREGATED  HILL  BE  GROUPED 
TOGETHER  UNDER  A  COMMON  (OUTPUT)  COLUMN  NAME) 

IF  NEMNAME  IS  ALL  BLANKS  BRANCH  TO  "UPDATE  OUTPUT  TABLES" 
(ASSUME  NEH  CARD  HAS  "RHS"  CARD) 

IF  (NBLANK.EQ.8)  GO  TO  230 

COMPARE  NEMNAME  MITH  COLNAME  (THE  NEMNAME  OF  THE  PREVIOUS  CARD) 
(CONSIOER  ONLY  NONBLANK  CHARACTERS  OF  NEMNAME) 

NONBLK  =  8  -  NBLANK 
DO  220  1=1 , NONBLK 

IF  NO  MATCH,  BRANCH  TO  "UPDATE  OUTPUT  TABLES" 

IF  ( NEMNAME ( I ) . NE . COLNAME ( I ) )  GO  TO  230 
CONTINUE 

NAMES  MATCH.  OUTPUT  TABLES  FOR  THIS  COLUMN  HAVE  ALREADY  BEEN 
SET  UP. 

BRANCH  TO  "PROCESS  ROM  NAMES  AND  VALUES  FROM  CURRENT  CARD" 

GO  TO  275 

UPDATE  OUTPUT  TABLES  FOR  PREVIOUS  COLUMN  MITH 

POMNAME  (LAST  ROHNAME  ENCOUNTERED)  AND  ROHVALU  (ASSOCIATED 

MPS  MATRIX  ENTRY)  BY  CALLING  SUBROUTINE  UPDATE 

CALL  UPDATE! LASTIX, ROHNAME, F7HVALU,PBLANK,ARITH,GEOM, COUNT, 

1  MINUS) ) 

( LASTIX  -  INDEX  OF  LAST  EN  TY  IN  OUTPUT  TABLES) 

(PBLANK  -  NUMBER  OF  BLANKS  ON  END  OF  ROHNAME) 


OUTPUT  PREVIOUS  COLUMN  BY  CALLING  SUBROUTINE  COLOUT 
(COMMON  BLOCK2  SHOULD  BE  HELL-DEFINED  AT  THIS  POINT) 
(COLNAME  -  OUTPUT  NAMF  OF  AGGREGATED  OLUMN) 


7U.  “ 


(NAMETAB  -  LIST  OF  AGGREGATED  ROW  NAMES  FOR  THIS  COLUMN) 
(VALUTAS  -  CORRESPONDING  LIST  OF  AGGREGATED  MPS  MATRIX  ENTRIES) 
(LASTIX  -  INDEX  OF  LAST  ENTRY  IN  NAMETAB  AND  VALUTAB) 


1 


1 


396. 

c — 

397. 

C — 

390. 

c — 

399. 

C — 

400. 

401  . 

C — 

402. 

c — 

403. 

C-- 

404. 

c— 

405. 

406. 

c~ 

407. 

c— 

400. 

c~ 

409. 

410. 

240 

411  . 

412. 

c— 

413. 

C” 

414. 

c— 

415. 

c— 

416. 

c— 

417. 

250 

410. 

419. 

420. 

421  . 

422. 

423. 

260 

424. 

c— 

425. 

c— 

426. 

c~ 

427. 

420. 

C" 

429. 

c— 

430. 

C~ 

431. 

C — 

432. 

433. 

434. 

435. 

270 

436. 

c— 

437. 

c — 

430. 

c — 

439. 

c— 

440. 

c-- 

441  . 

442. 

443. 

C” 

444. 

c— 

445. 

c-- 

446. 

C~ 

447. 

c-- 

CALL  COLOUT( LASTIX) 

IF  NAMES  DID  NOT  MATCH  BECAUSE  NEW  CARD  WAS  "RHS"  CARD. 

BRANCH  TO  "RHS  SEGMENT  BEGINS" 

00  240  1=1.4 

IF  TYPE  NOT  EQUAL  TO  *R* . *H’ » 'S' . '  BRANCH  TO  "NEW  COLUMN" 

IF  (TYPIN(I).NE.RHSII))  GO  TO  250 
CONTINUE 
GO  TO  400 

NEW  COLUMN  ENCOUNTERED. 

ERASE  OUTPUT  TABLES.  NAMETAB  AND  VALUTAB  (A  SAFETY  MEASURE) 

NERASE  =  LASTIX  ♦  1 
NERASE  =  MINO(MAXENT, NERASE) 

DO  260  1=1. NERASE 
VALUTAB(I)  =  0. 

00  260  J=1 .0 

NAMETAB) I, J)  =  BLANK 
CONTINUE 

RESET  LASTIX  (INDEX  OF  LAST  ENTRY  IN  OUTPUT  TABLES)  TO  ZERO 
LASTIX  =  0 

SAVE  NEW  COLUMN  NAME  AS  COLNAME  AND  ERASE  ROWNAME  (PREVIOUS 
ROWNAME  PROCESSED) 

00  270  1=1.0 

COLNAME ( I )  =  NEWNAME(I) 

ROWNAME ( I )  =  BLANK 
CONTINUE 

RESET  PBLANK  (NUMBER  OF  BLANKS  AT  END  OF  PREVIOUS  ROWNAME) 

TO  EIGHT  AND 

ROWVALU  (AGGREGATE  MPS  ENTRY  FOR  PREVIOUS  ROW  NAME)  TO  ZERO 

PBLANK  =  0 
ROWVALU  =  0. 

PROCESS  ROW  NAMES  AND  VALUES  FROM  CURRENT  CARO 
LOOP  ONCE  FOR  EACH  (OF  TWO)  ROW  NAMES  (LOOP  OVER  I) 


448.  275  00  370  1=1.2 

449.  C - 

450.  C—  (ASSUME  MPS  INPUT  FILE  IS  SORTED  SO  THAT, FOR  EACH  INPUT 

451 .  c—  COLUMN,  ROM  NAMES  WITH  THE  SAME  ROOT  ARE  GROUPED  TOGETHER 

452.  C—  IN  ASCENDING  ORDER  OF  PERIOD  NUMBER.  CONSEQUENTLY,  AFTER 

453.  c—  ROW  NAMES  ARE  REFORMED,  THE  ROWS  WHICH  ARE  TO  BE  AGGREGATED 

454.  c—  FOR  THAT  INPUT  COLUMN  WILL  BE  GROUPED  TOGETHER  UNDER  A 

455.  c—  COMMON  (OUTPUT)  ROW  NAME.  HOWEVER,  SINCE  SEVERAL  INPUT 

456.  c—  COLUMNS  MAY  NEED  TO  BE  AGGREGATED  UNDER  ONE  COLUMN  NAME 

457.  C—  IT  IS  NECESSARY  TO  MAINTAIN  NAMETAB  (TABLE  OF  (OUTPUT)  ROW 

458.  c—  NAMES  ENCOUNTERED  FOR  THAT  (OUTPUT)  COLUMN),  AND  VALUTAB 

459.  C—  (TABLE  OF  CORRESPONDING  (AGGREGATE)  MPS  MATRIX  ENTRIES) 

460.  C— 

461.  c—  MOVE  RNAME(I)  (INPUT  ROW  NAME  BEING  PROCESSED)  INTO  NAMEIN 

462.  C—  (CALL  STATEMENT  WILL  NOT  ACCEPT  AN  IMPLIED  DO  LOOP) 

463.  C - 

464.  DO  280  J=1 ,8 

465.  NAMEIN(J)  =  RNAMEI I , J ) 

466.  280  CONTINUE 

467.  C  — 

468.  C—  REFORM  INPUT  ROW  NAME  BY  CALLING  SUBROUTINE  RENAME 

469.  C - 

470.  CALL  RENAME ( NAMEIN.NEWNAME .INEWPR .NBLANK ) 

471  .  C - 

472.  C—  (NEWNAME  -  NAME  OF  INPUT  ROW  AS  IT  IS  TO  APPEAR  ON  OUTPUT) 

473.  C -  (NBLANK  -  NUMBER  OF  BLANKS  ON  END  OF  NEWNAME) 

474.  C— 

475.  C—  IF  INPUT  ROW  NAME  WAS  ALL  BLANKS,  SKIP  TO  "END  OF  LOOP" 

476.  C-— 

477.  IF  (NBLANK. EQ. 6)  GO  TO  370 

478.  C— 

479.  C -  IF  PREVIOUS  ROW  NAME  ALL  BLANKS,  BRANCH  TO  "NEW  ROW  NAME" 

480.  C— 

481.  IF  ( PBLANK. EQ.8 )  GO  TO  350 

482.  C - 

483.  C—  COMPARE  NEWNAME  WITH  ROWNAME  (PREVIOUS  ROWNAME  PROCESSED) 

484.  C—  (CONSIDER  ONLY  NONBLANK  CHARACTERS) 

485.  C— 

486.  NONBLK  =  8  -  NBLANK 

487.  DO  285  J=1 .NONBLK 

488.  C - 

489.  c— '  IF  NO  MATCH,  BRANCH  TO  "UPDATE  OUTPUT  TABLES" 

490.  C - 

491 .  IF  ( NEWNAME (J).NE.ROWNAME(J))  GO  TO  290 

492.  285  CONTINUE 

492.1  IF  ( ARITH )  GO  TO  288 

492.2  IF  (RVALU(I).LT.O.O)  GO  TO  287 

492.3  ROWVALU=ROWVALU*RVALU(I> 

492.4  286  COUNT=COUNT*1 

492.5  GO  TO  370 

492.6  287  ROWVALU=ROWVALU»ABS( RVALUt I ) ) 

492.8  GO  TO  286 


494.  C—  NAMES  MATCH. 

495.  c—  ADO  RVALU  (CURRENT  MATRIX  ENTRY)  TO  ROMVALU  (PREVIOUS  TOTAL) 

496.  C—  ANO  BRANCH  TO  "END  OF  LOOP" 

497.  C - 

493.  288  ROMVALU  =  ROMVALU  ♦  RVALU(I) 

499.  GO  TO  170 

500.  C— 

501.  c—  UPDATE  OUTPUT  TABLES  MITH  ROMNAME  (PREVIOUS  ROM  NAME) 

502.  c—  AND  ROMVALU  (CORRESPONDING  MATRIX  ENTRY)  BY  CALLING 

503.  C—  SUBROUTINE  UPDATE 

504.  C - 

505.  290  CALL  UPDATE) LASTIX, ROMNAME .ROMVALU, PBLANK, ARITH.GEOM, COUNT, 

505.1  1  MINUS1 ) 

506.  C  — 

507.  C—  (LASTIX  -  INOEX  OF  LAST  ENTRY  IN  OUTPUT  TABLES) 

508.  c-—  ( PBLANK  -  NUMBER  OF  BLANKS  ON  END  OF  ROMNAME) 

509.  C - 

510.  C—  NEH  ROMNAME  ENCOUNTERED. 

511.  c—  SAVE  NEWNAME  (CURRENT  ROM  NAME)  AS  ROMNAME  (PREVIOUS  ROM  NAME) 

512.  C—  SAVE  NBLANK  (NUMBER  OF  BLANKS  IN  NEMNAME )  AS  PBLANK 

513.  C—  SAVE  RVALU  (CORRESPONDING  MATRIX  ENTRY)  AS  ROMVALU 

514.  C  — 

515.  350  DO  360  L=1 .8 

516.  ROMNAME ( L )  =  NEMNAME ( L) 

517.  360  CONTINUE 

518.  PBLANK  =  NBLANK 

518.1  IF  ( ARITH )  GO  TO  364 

518.2  IF  (RVALU(I).LT.O.O)  GO  TO  365 

518.3  364  ROMVALU=RVALU( I ) 

518.31  MINUSHFALSE 

518.4  GO  TO  370 

518.5  365  ROMVALU=ABS(RVALU(I)) 

518.6  MINUS1 =TRUE 

520.  C— 

521.  C—  END  OF  LOOP 

522.  C— 

523.  370  CONTINUE 

524.  C  — 

525.  c—  BOTH  ROM  NAMES  FROM  INPUT  CARD  HAVE  NON  BEEN  PROCESSED. 

526.  C™  GO  READ  ANOTHER  COLUMN  CARD 

527.  C - 

528.  GO  TO  205 

529.  C  — 

530.  C - 

531 .  C— 

532.  C— 

533.  C— 

534.  C  RHS  SEGMENT  BEGINS 

535.  C— 

536.  C—  OUTPUT  "RHS"  CARO 


538. 

400 

WRITE  (9,9161 

539. 

916 

FORMAT  f  'RHS ' ) 

540. 

c— 

54  f . 

c— 

RESET  ROWNAME  (PREVIOUS  ROW  NAME)  TO  BLANKS  AND 

542. 

c — 

ROWVALU  (ASSOCIATED  MPS  MATRIX  ENTRY)  TO  ZERO  AND 

543. 

c — 

PBIANK  (NUMBER  OF  BLANKS  ON  END  OF  ROWNAME)  TO  EIGHT 

544. 

c — 

545. 

00  405  1=1 .8 

546. 

ROWNAME! I)  =  BLANK 

547. 

405 

CONTINUE 

548. 

ROWVALU  =  0. 

549. 

PBLANK  =  8 

550. 

c - 

551  . 

c— 

BEGIN  RHS  CARD  CYCLE  -  ONE  PASS  FOR  EACH  CARD  READ 

552. 

c — 

553. 

c — 

SET  PASS1  (FIRST  PASS  INDICATOR)  ON  OR  OFF 

554. 

c — 

555. 

PASS1  =  TRUE 

556. 

GO  TO  420 

557. 

410 

PASS1  =  FALSE 

558. 

c— 

559. 

c— 

READ  A  CARO  USING  COLUMN  CARD  FORMAT 

560. 

c— 

561  . 

420 

READ  (8,914)  TYPIN.CNAME , ( RNAME1 1 ,1 ) ,1=1 ,8 ) .RVALUt 1 ) , 

562. 

1  ( RNAMEf  2,J),J=1 ,6) ,RVALU( 2 ) 

563. 

c— 

564. 

c— 

(TYPIN  -  BLANK) 

565. 

c-~ 

( CNAME  -  RHS  NAME) 

566. 

c— 

(RNAMEf 1)  AND  (2)  -  ROW  NAMES  OF  RHS  ENTRIES) 

567. 

c — 

< RVALUt 1  I  AND  (2)  -  RHS  VALUES) 

568. 

c— 

569. 

c— 

ON  FIRST  PASS  ONLY,  SAVE  CNAME  AS  COLNAME  (NAME  OF  RHS) 

570. 

c— 

TYPIN  AS  TYPE  (BLANKS) 

570.1 

c— 

571. 

IF  ( .N0T.PASS1 )  GO  TO  440 

572. 

00  430  1=1 ,8 

573. 

COLNAME! I)  =  CNAME ( I ) 

574. 

430 

CONTINUE 

574.1 

DO  435  1=1 ,4 

574.2 

TYPE(I)  =  TYPIN! I ) 

574.3 

435 

CONTINUE 

575. 

c— 

576. 

c— 

PROCESS  ROW  NAME  AND  VALUES  FROM  CURRENT  CARD 

577. 

c — 

578. 

c — 

LOOP  ONCE  FOR  EACH  (OF  TWO)  ROW  NAMES  (LOOP  OVER  I) 

579. 

c— 

580. 

440 

DO  530  1=1,2 

581  . 

c— 

582. 

c — 

(ASSUME  HPS  INPUT  FILE  SORTED  SO  THAT  ROW  NAMES  WITH 

SAME 

583. 

c — 

ROOT  ARE  GROUPED  TOGETHER  IN  ASCENDING  ORDER  OF  PERIOD 

584. 

c — 

NUMBER.  CONSEQUENTLY,  AFTER  ROW  NAMES  ARE  REFORMED, 

THE 

585. 

c — 

ROWS  WHICH  ARE  TO  BE  AGGREGATED  ON  THE  RHS  WILL  BE 

GROUPED  TOGETHER  UNOER  A  COMMON  (OUTPUT)  ROW  NAME) 


586.  C— 

587.  C— 

588.  C—  MOVE  RNAME(I)  (INPUT  ROW  NAME  BEING  PROCESSED)  INTO  NAMEIN 

589.  C -  (CALL  STATEMENT  WILL  NOT  ACCEPT  AN  IMPLIED  DO  LOOP) 

590.  C— 

591  .  DO  445  J=1 ,8 

592.  NAMEIN(J)  =  RNAME(I.J) 

593.  445  CONTINUE 

594.  C— 

595.  C -  REFORM  INPUT  ROW  NAME  BY  CALLING  SUBROUTINE  RENAME 

596.  C— 

597.  CALL  RENAME (NAME IN. NEWNAME  , INEWPR iNBLANK ) 

598.  C - 

599.  C—  (NEWNAME  -  NAME  OF  INPUT  ROW  AS  IT  IS  TO  APPEAR  ON  OUTPUT) 

600.  c—  ( NBLANK  -  NUMBER  OF  BLANKS  AT  END  OF  NEWNAME) 

601.  C— 

602.  c—  IF  PREVIOUS  ROW  NAME  ALL  BLANKS  (I.E.  FIRST  NAME  ON  FIRST  CARD) 

603.  C—  BRANCH  TO  "NEW  ROW  NAME" 

604.  C— 

605.  IF  ( PBLANK.EQ.8)  GO  TO  475 

606.  C  — 

607.  C—  IF  INPUT  ROW  NAME  NOT  ALL  BLANKS 

608.  C—  BRANCH  TO  "COMPARE  NEWNAME  WITH  ROWNAME" 

609.  C— 

610.  IF  (NBLANK.LT. 8)  GO  TO  450 

611.  C— 

612.  C—  INPUT  ROW  NAME  ALL  BLANKS. 

613.  C—  IF  THIS  IS  FIRST  NAME  ON  CARD  ASSUME  IT  IS  "BOUNDS"  CARD  AND 

614.  C—  BRANCH  TO  "OUTPUT  PREVIOUS  ROW  ENTRY" 

615.  C—  OTHERWISE  BRANCH  TO  "END  OF  LOOP" 

616.  C— 

617.  IF  ( I.Eq. 1 )  GO  TO  470 

618.  GO  TO  530 

619.  C— 

620.  C—  COMPARE  NEWNAME  WITH  ROWNAME  (PREVIOUS  ROW  NAME) 

621.  c—  (CONSIDER  ONLY  NONBLANK  CHARACTERS  OF  NEWNAME) 

622.  C— 

623.  450  NONBLK  =  8  -  NBLANK 

624.  DO  460  L=1 .NONBLK 

625.  C— 

626.  C—  IF  NO  MATCH,  BRANCH  TO  "OUTPUT  PREVIOUS  ROW  ENTRY" 

627.  C— 

628.  IF  (NEWNAME!  L).NE.ROWNAME(D)  GO  TO  470 

629.  460  CONTINUE 

630.  C— 

631.  C—  NAMES  MATCH. 

632.  C—  ADO  CURRENT  RHS  ENTRY  TO  ROWVALU  (PREVIOUS  TOTAL)  AND 

633.  C—  BRANCH  TO  "END  OF  LOOP" 

634.  C - 

635.  ROWVALU  =  ROWVALU  *  RVALU(I) 

636.  GO  TO  530 

637.  C— 


OUTPUT  PREVIOUS  ROM  ENTRY  BY  CALLING  SUBROUTINE  CARDOUT 


! 


638. 

c— 

OUTPUT  PREVIOUS  ROM  ENTRT  BY  CALLING  SUBROUTINE 

CARDOUT 

639. 

c - 

640. 

470 

CALL  CARDOUT! TYPE iCOLNAME. 1 > ROHNAME , ROWVALU ■ ROWNAME » ROWVALU ) 

641. 

c— 

642. 

c— 

(3-RO  ARGUMENT  IN  CALL  IS  NUMBER  OF  ROM  ENTRIES 

SUBMITTED 

643. 

c — 

FOR  OUTPUT  -  IN  THIS  CASE  ONLY  ONE  SO  THE  6‘TH 

AND  7-TH 

644. 

c— 

ARGUMENTS  HILL  BE  IGN0RE01 

645. 

c— 

646. 

c— 

NEW  ROM  NAME  ENCOUNTERED. 

647. 

c— 

IF  THIS  IS  FIRST  NAME  ON  CARD  CHECK  IF  •'BOUNDS" 

CARO 

648. 

c— - 

OTHERHJSE  BRANCH  TO  "RESET  OUTPUT  BUFFERS" 

649. 

c— 

650. 

475 

IF  (I.NE.1 )  GO  TO  500 

651  . 

DO  480  L=1 .4 

652. 

c— 

653. 

c— 

IF  TYPE  NOT  EQUAL  TO  *B’ . '0* , *0* . ‘N* , 

654. 

c— 

BRANCH  TO  "RESET  OUTPUT  BUFFERS” 

655. 

c— 

656. 

IF  (TYPIN(L).NE. BOUNDS! L>)  GO  TO  500 

657. 

480 

CONTINUE 

658. 

GO  TO  600 

659. 

c— 

660. 

c— 

RESET  OUTPUT  BUFFERS  -  SAVE  NEHNAME  AS  ROMNAME 

661  . 

c— 

-  SAVE  NBLANK  AS  P8LANK 

662. 

c — 

-  SAVE  RVALU  AS  ROMVALU 

663. 

c— 

664. 

500 

00  510  L=1.8 

665. 

ROMNAME ( L )  =  NEHNAME ( L ) 

666. 

510 

CONTINUE 

667. 

ROWVALU  *  RVALU(I) 

668. 

PBLANK  =  NBLANK 

669. 

c— 

670. 

c— 

ENO  OF  LOOP 

671  . 

c— 

672. 

530 

CONTINUE 

673. 

C— 

674. 

c— 

BOTH  ROM  NAMES  FROM  INPUT  CARD  HAVE  NOM  BEEN  PROCESSED. 

675. 

c— 

GO  READ  ANOTHER  RHS  CARO 

676. 

C— 

677. 

GO  TO  410 

678. 

c— 

679. 

c — 

680. 

c— 

681  . 

c— 

682. 

c— 

683. 

C  BOUNDS  SEGMENT  BEGINS 

684. 

C — 

685. 

c— 

OUTPUT  "BOUNDS”  CARO 

686. 

c — 

687. 

600 

WRITE  (9,918) 

688. 

918 

FORMAT  1 'BOUNDS’ ) 

689. 

c — 

BEGIN  BOUNDS  CARO  CYCLE  -  ONE  PASS  FOR  EACH  CARO  REAO 


690. 

691 . 

692. 

693. 

694. 

695. 

696. 

697. 

698. 

699. 

700. 
701  . 

702. 

703. 

704. 

705. 

706. 

707. 

708. 

709. 

710. 
711  . 

712. 

713. 

714. 

715. 

716. 

717. 

718. 

719. 

720. 
721  . 

722. 

723. 

724. 

725. 

726. 

727. 

728. 

729. 

730. 

731 . 

732. 

733. 

734. 

735. 

736. 

737. 

738. 

739. 

740. 

741. 


C— 

c— 

c— 

c—  SET  PASS1  (FIRST  PASS  INOICATOR )  ON  OR  OFF 
C— 

PASS1  =  TRUE 
GOTO  625 

620  PASS)  =  FALSE 
C— 

C—  REAO  A  CARO  USING  BOUND  CARD  FORMAT 
C — 

625  READ  (8,920)  TYPIN, ( RNAMEl 1 ,1 ) ,1=1 ,8) .CNAME .VALUE 
920  FORMAT  (4A1 ,8A1 ,2X,8A1 ,2X,F12.6 ) 

C— 

C— -  (TYPIN  -  BOUND  TYPE) 

C—  (RNAME(I)  ~  BOUND  NAHE ) 

C—  (CNAME  -  COLUMN  NAME  I 

C—  (VALUE  -  BOUND  VALUE)  (ASSUME  ONLY  ONE  VALUE  INPUT  PER  CARO) 

C — 

C -  SKIP  COMMENT  CAROS 

C— 

IF  ( TYPINI 1 ) . EG. ASTERSK )  GO  TO  625 

C— 

C—  ON  FIRST  PASS  ONLY,  SAVE  RNAME(  1  )  AS  ROWNAME  (NAME  OF  BOUNDS  ••RON") 
C— - 

IF  (.NOT. PASS) )  GO  TO  640 
DO  635  1=1 ,8 

ROWNAME ( I )  =  RNAMEI 1,1) 

635  CONTINUE 
C — 

C -  REFORM  INPUT  COLUMN  NAME  BY  CALLING  SUBROUTINE  RENAME 

C— 

640  CALL  RENAME) CNAME .NEWNAME , INEWPR .NBLANK ) 

C — 

C — *  (NEWNAME  *  NAME  OF  INPUT  COLUMN  NAME  AS  IT  IS  TO  APPEAR  ON  OUTPUT) 
C—  (NBLANK  -  NUMBER  OF  BLANKS  AT  END  OF  NEWNAME) 

C -  (INEWPR  *  INDEX  OF  OUTPUT  PERIOD  NUMBER 

c—  *  EQUALS  ZERO  IF  CNAME  DID  NOT  END  WITH  VALID  INPUT  PERIOO 

C—  NUMBER ) 

c— 

C—  IF  FIRST  PASS,  BRANCH  TO  "NEW  NAME/TYPE" 

c— 

IF  ( PASS1  )  GO  TO  700 

C™ 

C -  (ASSUME  MPS  INPUT  FILE  SORTED  SO  THAT  FOR  EACH  BOUND  TYPE 

c—  ENCOUNTERED,  COLUMN  NAMES  WITH  THE  SAME  ROOT  ARE  GROUPED  TOGETHER 
C—  IN  ASCENDING  ORDER  OF  PERIOD  NUMBER.  CONSEQUENTLY,  AFTER  COLUMN 
c—  NAMES  ARE  REFORMED,  BOUNDS  OF  THE  SAME  TYPE  WHICH  ARE  TO  BE 

C—  AGGREGATED  HILL  BE  GROUPED  TOGETHER  UNOER  A  COMMON  (OUTPUT) 

C—  COLUMN  NAME) 

c*~ 

C—  IF  NEWNAME  ALL  BLANKS  BRANCH  TO  "CHANGE  IN  BOUND  NAME/TYPE" 


c 

c 


(ASSUME  "END AT A"  CARD  ENCOUNTERED) 


I 


742. 

743. 

744. 

745. 

746. 

747. 

748. 

749. 

750. 

751 . 

752. 

753. 

754. 

755. 

756. 

757. 

758. 

759. 

760. 

761. 

762. 

763. 

764. 

765. 

766. 

767. 

768. 

769. 

770. 
771  . 

772. 

773. 

774. 

775. 

776. 

777. 

778. 

779. 

780. 

781. 

782. 

783. 

784. 

785. 

786. 

787. 

788. 

789. 

790. 
791  . 

792. 

793. 


C - 

c— 

c— 

c— 


c — 
c — 
c— 
c— 
c— 
670 


C— 

c — 
c— 
c— 

956 

C— 

c — 
c — 
c — 
c— 
680 


IF  (NBUNK.EQ.8)  GO  TO  670 

COMPARE  NEMNAME  WITH  COLNAME  (THE  NEHNAME  OF  THE  PREVIOUS  CARD) 
(CONSIDER  ONLY  THE  NON-BLANK  CHARACTERS  OF  NEWNAME) 

NONBLK  =  8  -  NBLANK 
DO  650  1=1 .NONBLK 

IF  NO  MATCH,  BRANCH  TO  "CHANGE  IN  BOUND  NAME/TYPE" 

IF  ( NEWNAME ( I ) . NE . COLNAME ( I > )  GO  TO  670 
CONTINUE 

NAMES  MATCH.  NOW  COMPARE  BOUND  TYPES 
DO  660  1=1 ,4 

IF  NO  MATCH,  BRANCH  TO  "CHANGE  IN  BOUND  NAHE/TYPE" 

IF  ( TYPIN1 I ) . NE . TYPE ( I > )  GO  TO  670 
CONTINUE 

NAMES  AND  BOUND  TYPE  MATCH. 

INCREMENT  NBOUNOS  (NUMBER  OF  BOUNDS  ENCOUNTERED) 

ADO  VALUE  TO  BOVALU  (AGGREGATE  BOUND  VALUE) 

GO  RE AO  A  NEW  CARD 

NBOUNOS  =  NBOUNOS  ♦  t 
BDVALU  =  BOVALU  ♦  VALUE 
GO  TO  620 

CHANGE  IN  BOUND  NAME/TYPE. 

IDENTIFY  BOUND  TYPE  OF  PREVIOUS  NAME/TYPE 

IF  ( TYPE( 3) . EG.FR( 2 ) .OR .TYPE ( 3 > .EQ.MI) 2 ) )  GO  TO  680 
IF  ( TYPE( 3 ) . EQ. LO( 2 ) )  GO  TO  685 

IF  ( TYPE<  3) .EO. FX( 2 ) .OR .TYPE! 3 ) .EQ.UP1 2 ) )  GO  TO  690 

TYPE  HAS  NOT  ONE  OF  (MI, FR.FX, UP,  OR  LO). 

PRINT  WARNING  AND  TREAT  SAME  AS  "FREE"  OR  "MINUS  INFINITY" 

WRITE  (6,956)  TYPE .RONNAME .COLNAME , BDVALU 

FORMAT  ( 1H  ,4A1 ,8A1 ,2K,8A1 ,2X,F12.6, '  ««  UNRECOGNIZED  BOUND  TYPE') 

BOUND  TYPE  WAS  EITHER  "FREE"  OR  "MINUS  INFINITY". 

OUTPUT  BOUND  CARD  BY  CALLING  SUBROUTINE  CARDOUT  AND 
BRANCH  TO  "NEW  NAME/TYPE" 

CALL  CAROOUT(TYPE, RONNAME, 1 .COLNAME .BOVALU, COLNAME, BOVALU) 


GO  TO  700 


794. 

795. 

796. 

797. 

798. 

799. 

800. 
601 . 
802. 

803. 

804. 

805. 

806. 

807. 

808. 

809. 

810. 
811. 
812. 

813. 

814. 

815. 

816. 
817. 
618. 

819. 

820. 
821  . 
822. 

823. 

824. 

825. 

826. 

827. 

828. 

829. 

830. 

831. 

832. 

833. 

834. 

835. 

836. 

837. 

838. 

839. 

840. 
841  . 
842. 
643. 

844. 

845. 


c— 

C—  ( 3-RO  ARGUMENT  IN  CALL  IS  NUMBER  OF  ENTRIES  SUBMITTED  FOR 

C -  OUTPUT  -  IN  THIS  CASE  ONLY  ONE  SO  THE  6-TH  AND  7-TH 

C -  ARGUMENTS  MILL  BE  IGNORED) 

C— 

c— 

c—  BOUND  TYPE  WAS  "LONER". 

c—  AVERAGE  BDVALU  (AGGREGATE  BOUND  VALUE)  OVER  NPR  (NUMBER  OF  PERIODS 
C—  IN  AGGREGATION) 

c—  OUTPUT  BOUND  CARO  BY  CALLING  SUBROUTINE  CARDOUT  ANO 
C—  BRANCH  TO  "NEW  NAME/TYPE" 

c— 

685  BDVALU  =  BDVALU/NPR 

CALL  CARDOUT ( TYPE .ROMNAME , 1 .COLNAME .BDVALU .COLNAME , BDVALU ) 

GO  TO  700 

c— 

c—  BOUND  TYPE  MAS  EITHER  "FIXED"  OR  "UPPER". 

c—  COMPARE  NBOUNDS  (NUMBER  OF  BOUNDS  ENCOUNTERED)  WITH  NPR  (NUMBER 
C—  OF  PERIODS  IN  AGGREGATION) 

c—  IF  EQUAL-  TREAT  SAME  AS  LOMER  BOUND  -  BRANCH  TO  "TYPE  MAS  LONER" 

c— 

690  IF  (NBOUNDS. EQ. NPR )  GO  TO  685 

c— 

C—  INCORRECT  NUMBER  OF  BOUNOS  ENCOUNTERED.  (ASSUME  TOO  FEM) 
c—  (SINCE  DEFAULT  UPPER  BOUND  IS  INFINITY  THE  AVERAGE  UPPER  BOUND 
C—  MUST  BE  INFINITY) 

C—  PRINT  HARNING 

c—  IF  UPPER  BOUND  00  NOT  OUTPUT  A  BOUND  CARD  BUT 
C—  BRANCH  TO  "NEN  NAME/TYPE" 

c—  IF  FIXED  BOUND  CHANGE  TYPE  TO  "LOWER"  AND 
C—  BRANCH  TO  "TYPE  HAS  LOMER" 

C— 

WRITE  (6,958)  TYPE .ROWNAME .COLNAME .BDVALU, NPR .NBOUNDS 
958  FORMAT  ( (H  ,4A1  ,8AI  .2X.8A1 .2X.F12.6,  •  BOUNDS  EXPECTED  M3, 

1  '  BOUNDS  ENCOUNTERED  M3,'  *»  TOO  FEM  BOUNDS') 

IF  ( TYPE( 3 ) . EQ.UP( 2 ) )  GO  TO  700 
TYPE( 2  )  =  LO( 1 ) 

TYPE( 3 )  =  LO( 2 ) 

GO  TO  685 

c— 

c—  NEW  NAME/TYPE  ENCOUNTERED. 

c—  IF  BREAK  CAUSED  BY  "ENOATA"  CARD  BRANCH  TO  "END  SEGMENT" 

c— 

700  00  710  1=1 ,4 

c— 

C—  IF  TYPE  ON  CURRENT  CARD  NOT  EQUAL  TO  ’E' , 'N' , 'D' , 'A' 

C—  BRANCH  TO  "RESET  OUTPUT  BUFFERS" 

c— 

IF  (TYPIN(I).NE.ENDATA(D)  GO  TO  720 
71 0  CONTINUE 
GO  TO  800 


1 


646. 

c— 

847. 

c— 

RESET  OUTPUT  BUFFERS  -  SAVE  NEWNAME  AS  COLNAME 

646. 

c— 

-  SAVE  TYPIN  AS  TYPE 

649. 

c— 

-  SAVE  VALUE  AS  BOVALU 

850. 

c — 

-  RESET  NBOUNOS  TO  ONE 

851 . 

c — 

852. 

720 

DO  730  1=1,8 

853. 

COLNAME ( I )  =  NEWNAME ( I ) 

854. 

730 

CONTINUE 

855. 

DO  735  1=1,4 

856. 

TYPE(I)  =  TYPIN(I) 

857. 

735 

CONTINUE 

858. 

BDVALU  =  VALUE 

859. 

NBOUNDS  =  1 

860. 

c— 

861  . 

c— 

IF  INEWPR  (INDEX  OF  OUTPUT  PERIOD  NUMBER)  IS  INVALIO  SET  NPR  TO 

862. 

c— 

ONE  ANO  GO  READ  A  NEW  CARD 

863. 

c — 

864. 

IF  (INEWPR. GT.O)  GO  TO  740 

865. 

NPR  =  1 

866. 

GO  TO  620 

867. 

c — 

868. 

c — * 

VALID  INEWPR. 

869. 

c— 

LOOKUP  NPR  (NUMBER  OF  PERIODS  IN  AGGREGATION)  IN  TABLE  LISTIN 

870. 

c— 

(I-TH  NUMBER  IN  LISTIN  IS  NUMBER  OF  PERIODS  FROM  INPUT  MODEL 

871. 

c— 

TO  BE  AGGREGATED  WHEN  FORMING  I-TH  PERIOD  OF  OUTPUT  MODEL) 

872. 

c— 

873. 

740 

NPR  =  LISTIN( INEWPR  ) 

874. 

c— 

875. 

c— 

GO  READ  A  NEW  BOUNDS  CARD 

876. 

c - 

877. 

GO  TO  620 

878. 

c — 

879. 

c— 

880. 

c — 

881  . 

c — 

882. 

C  END 

SEGMENT 

883. 

c— 

884. 

c— 

OUTPUT  "ENDATA"  CARO  AND  STOP 

885. 

c — 

886. 

800 

WRITE  (9,9221 

887. 

922 

FORMAT! 'ENDATA' ) 

888. 

STOP 

889. 

ENO 

890. 

c— 

891  . 

c — 

892. 

c— 

893. 

c — 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

894. 

c — 

895. 

c— 

896. 

c— 

897. 

c— 

SUBROUTINE  RENAME 

1 


1 


1 


1 


SUBROUTINE  RENAME 


! 


898. 

899. 

900. 
901  . 

902. 

903. 

904. 

905. 

906. 

907. 
903. 

909. 

910. 

911. 

912. 

913. 

914. 

915. 

916. 

917. 

918. 

919. 

920. 

921. 

922. 

923. 

924. 

925. 

926. 

927. 

928. 

929. 

930. 

931. 

932. 

933. 

934. 

935. 

936. 

937. 

938. 

939. 

940. 

941 . 

942. 

943. 

944. 

945. 

946. 

947. 

948. 

949. 


-  INPUT  OLDNAME  (ANY  8  CHARACTER  NAME) 

-  SELECTS  LAST  TWO  NON-BLANK  CHARACTERS  OF  NAME 

-  CONVERTS  THESE  TO  A  (TWO-DIGIT)  INTEGER  NUMBER 

-  RETURNS  IF  NOT  A  VALID  INPUT  PERIOO  NUMBER 

-  CONVERTS  TO  (TWO-CHARACTER)  NEW  PERIOO  NUMBER 
ACCORDING  TO  AGGREGATION  SCHEME 

-  SUBSTITUTES  NEW  PERIOO  NUMBER  FOR  OLD  AT  ENO  OF 
NAME 

-  RETURNS  WITH  NEWNAME  (8  CHARACTER  NAME  WITH  NEW 

PERIOD  NUMBER  -  IF  VALID) 
INEWPR  (INTEGER  EQUIVALENT  OF  NEW 
PERIOD  NUMBER) 

NBLANK  (NUMBER  OF  BLANKS  AT  END  OF 
NAME) 


SUBROUTINE  RENAME( OLDNAME .NEWNAME , INEWPR .NBLANK ) 


CHARACTER*)  OLDNAME ( 8 ) ■ OLDPRf  2 ) , NEWNAME! 8 ) ,NEWPR<  2 ) .BLANK 
CHARACTER*!  PRNAMEl 1 00 ,2 ) 

INTEGER  IN0UT(20> 

COMMON  /BLOCK 1/N PRIM. NPROUT , INOUT , PRNAME 

COMMON  BLOCK)  VARIABLES  - 

(NPRIN  “  NUMBER  OF  PERIODS  IN  INPUT  MODEL) 

(NPROUT  '  NUMBER  OF  PERIODS  IN  OUTPUT  MODEL) 

(INOUT  -  LAST  INPUT  PERIOO  NUMBER  FOR  EACH  CORRESPONDING 
OUTPUT  PERIOD  NUMBER  -  I.E.  AGGREGATION  SCHEME) 
(PRNAME  -  TWO  CHARACTER  EQUIVALENTS  FOR  EACH  POSSIBLE  PERIOO 
NUMBER  -  I.E.  CO'.'O'l  TO  (  *9*  ,  1  9‘  )  ) 


INITIALIZE  BLANK  TO  BLANK 
NBLANK  TO  ZERO 
INEWPR  TO  ZERO  AND 
OLD PR  TO  ( 'O' , 'O'  ) 

DATA  BLANK/1  '/ 

NBLANK  =  0 
INEWPR  =  0 

OLDPRt 1 )  =  PRNAME! 1,1) 

OLOPR( 2 )  =  PRNAME (1,2) 


PROCESS  OLDNAME  CHARACTER  BY  CHARACTER  BEGINNING  WITH 
LAST  CHARACTER  AND  INITIALLY  SET  NEWNAME  EQUAL  TO  OLDNAME 

DO  10  1=1,8 
L  =  9  -  I 

NEWNAME! L )  =  OLDNAME! LI 


COMPUTE  NBLANK  (NUMBER  OF  BLANKS  ON  END  OF  OLDNAME) 
(ASSUME  NO  BLANKS  OCCUR  WITHIN  THE  BODY  OF  THE  NAME) 


IF  (OLDNAME(L).EQ. BLANK)  N8LANK  «  NBLANK  ♦  I 


950. 

IF  (OLDNAME(L).EQ. BLANK)  NBLANK  =  NBLANK  ♦  I 

951 . 

c— 

952. 

c— 

COMPUTE  NONBLK  (NUMBER  OF  NONBLANK  CHARACTERS  PROCESSED 

953. 

c— 

SO  FAR) 

954. 

c— 

955. 

NONBLK  =  I  -  NBLANK 

956. 

c— 

957. 

c— 

PLACE  LAST  TWO  NONBLANK  CHARACTERS  IN  OLDPR 

950. 

c— 

959. 

IF  (NONBLK. GT. 2. OR. NONBLK. EQ.O)  GO  TO  10 

960. 

INDEX  =  3  -  NONBLK 

961  . 

OLOPRf  INDEX)  =  OLDNAME(L) 

962. 

10 

CONTINUE 

963. 

c— 

964. 

c — 

IF  OLDNAME  IS  ALL  BLANKS,  RETURN 

965. 

c — 

966. 

IF  (NBLANK. EQ.O)  RETURN 

967. 

c — 

960. 

c — 

CONVERT  OLDPR  TO  INTEGER  EQUIVALENT  BT  CALLING  SUBROUTINE  CONVERT 

969. 

c— 

970. 

CALL  CONVERT( OLDPR, IOLDPR) 

971  . 

c— 

972. 

c — 

(IOLDPR  -  INTEGER  EQUIVALENT  OF  OLDPR 

973. 

c — - 

-  EQUALS  ZERO  IF  NOT  A  VALID  PERIOD  NUMBER) 

974. 

c — 

IF  OLDPR  NAS  NOT  A  VALID  PERIOD  NUMBER,  RETURN 

975. 

c— 

976. 

IF  (IOLDPR. EQ.O)  RETURN 

977. 

c— 

970. 

c— 

COMPARE  IOLDPR  NITH  INOUT  (LIST  OF  ENDING  PERIOD  NUMBERS) 

979. 

c— 

900. 

30 

00  40  1=1 .NPROUT 

901  . 

IF  ( IOLDPR. GT.INOUT(I))  GO  TO  40 

932. 

c— 

903. 

c— 

I  IS  NON  OUTPUT  PERIOD  NUMBER  CORRESPONDING  TO  OLDPR. 

934. 

c— 

SAVE  I  AS  INEHPR 

905. 

c— 

GET  CHARACTER  EQUIVALENT  OF  I  FROM  PRNAME  AND 

986. 

c— 

SAVE  IN  NEHPR 

907. 

c— 

BRANCH  TO  "CHANGE  PERIOD  NUMBER" 

988. 

c— 

989. 

INENPR  =  I 

990. 

NEWPR(I)  =  PRNAME (1*1 , 1  ) 

991 . 

NEHPR (  2  )  =  PRNAMEdM  ,2) 

992. 

GO  TO  50 

993. 

40 

CONTINUE 

994. 

c— 

995. 

c— 

NO  MATCH  FOUNO.  IOLDPR  MUST  BE  INVALID  PERIOD  NUMBER) 

996. 

c— 

RETURN  (INEHPR  HILL  EqUAL  ZERO) 

997. 

c — 

998. 

RETURN 

999. 

c — 

1000. 

c — 

CHANGE  PERIOD  NUMBER  HITHIN  NEHNAME  TO  NEH  PERIOD  NUMBER 

1001. 

c — 

AND  RETURN 

1 054. 

1055. 

1056. 

1057. 

1058. 

1059. 

1060. 
1061 . 
1062. 

1063. 

1064. 

1065. 

1066. 

1067. 

1068. 

1069. 

1070. 
1071  . 

1072. 

1073. 

1074. 

1075. 

1076. 

1077. 

1078. 

1079. 

1080. 
1081  . 
1082. 

1083. 

1084. 

1085. 

1086. 
1086.1 

1087. 

1088. 

1089. 

1089.1 

1090. 

1091 . 

1091.1 

1092. 

1093. 

1094. 

1095. 

1096. 

1097. 

1098. 

1099. 

1100. 
1101  . 
1102. 


c— 

C—  I-TH  CHARACTER  IS  NOT  A  VALID  DIGIT. 

C -  RETURN  (WITH  NUMBER  EQUAL  TO  ZERO) 

C — 

RETURN 

20  CONTINUE 

C — 

C -  N  HOLDS  DIGIT  EQUIVALENTS  OF  AB  CHARACTERS. 

C -  COMPUTE  NUMBER  (INTEGER  EQUIVALENT  OF  AB)  AND  RETURN 

c— 

NUMBER  =  1 0*N< 1 )  ♦  N( 2 ) 

RETURN 

END 

C— 

c— 

C— 

C—  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c— 

c— 

c— 

c -  SUBROUTINE  UPDATE 

c— 

C -  -  INPUT  LASTIX  (INDEX  OF  LAST  ENTRT  IN  OUTPUT  TABLES) 

c—  ROWNAME  (ROW  NAME  OF  ENTRY  TO  BE  ADDED  TO  TABLES) 

C—  ROWVALU  (ASSOCIATED  AGGREGATE  MPS  MATRIX  ENTRY) 

C—  PBLANK  (NUMBER  OF  BLANKS  AT  END  OF  ROWNAME ) 

C—  -  IF  MATCHING  ROW  NAME  IS  FOUND  IN  TABLE  NAMETAB  THEN 

C—  ROWVALU  IS  ADDED  TO  CORRESPONDING  ENTRY  IN  VALUTAS 

c—  -  IF  NO  MATCH  IS  FOUND  NEW  ENTRIES  ARE  SET  UP  IN  NAMETAB 

C—  AND  VALUTAB  AND  LASTIX  IS  INCREMENTED  BY  ONE 

c—  -  RETURNS  WITH  NEW  VALUE  OF  LASTIX 

C— 

SUBROUTINE  UPDATE ( LASTIX  ,  ROWNAM  .ROWVAL  , PBLANK  .ARITH , GEOM , COUNT > 

1  MINUS 1 ) 

c— 

CHARACTERS  COLNAMEI  8 )  > ROWNAME ( 8 ) , NAMETAB ( 100,8) 

DIMENSION  VALUTAB1 1 00 ) 

LOGICAL  ARITH, GEOM, MINUS1 .TRUE, FALSE 
INTEGER  PBLANK 

COMMON/BLOCK2/COLNAME , NAMETAB , VALUTAB .MAXENT 
DATA  TRUE, FALSE/. TRUE.,. FALSE./ 

C— 

C -  COMMON  BLOCK2  VARIABLES  - 

C -  (COLNAME  -  OUTPUT  NAME  OF  AGGREGATED  COLUMN) 

C -  (NAMETAB  -  LIST  OF  AGGREGATED  ROW  NAMES  ENCOUNTERED  FOR 

C—  THIS  COLUMN) 

C—  (VALUTAB  -  CORRESPONDING  LIST  OF  AGGREGATED  MPS  MATRIX  ENTRIES) 
C—  (MAXENT  -  MAXIMUM  NUMBER  OF  ENTRIES  IN  NAMETAB/VALUTAB 
C—  -  SHOULD  EQUAL  DIMENSION) 

C - 

c— 
c— 


IF  NO  PREVIOUS  ENTRIES  IN  OUTPUT  TABLES 
BRANCH  TO  "NEW  OUTPUT  TABLE  ENTRY" 


IF  ( LASTIX. EQ.  0 )  GO  TO  SO 


1103. 

c— - 

1104. 

10 

IF  ( LASTIX. EQ.O)  GO  TO  SO 

1105. 

c— 

1106. 

c— 

COMPARE  ROWNAME  TO  EACH  ENTRY  IN  NAMETAB 

1107. 

c — 

(CONSIDER  ONLY  NONBLANK  CHARACTERS  IN  ROWNAME) 

1108. 

c— 

1109. 

NONBLK  =  8  -  PBLANK 

1110. 

DO  30  IX=1, LASTIX 

1111. 

00  20  L=  1 , NOND LK 

1112. 

c — 

1113. 

c — 

IF  NO  HATCH,  GO  ON  TO  NEXT  NAMETAB  ENTRY 

1114. 

c — 

1115. 

IF  ( ROUNAHE (L).NE.NAhETABI  IX, LI)  GO  TO  30 

1116. 

20 

CONTINUE 

1117. 

c — 

1118. 

c — 

MATCHING  NAME  FOUND  IN  NAMETAB. 

1119. 

c — 

ADD  ROWVALU  TO  CORRESPONDING  ENTRY  IN  VALUTAB 

1120. 

c— 

RESET  ROWVALU  TO  ZERO  AND  RETURN 

1121. 

c-~ 

1121.1 

IF  ( ARITH I  GO  TO  22 

1121.2 

IF  ( MINUS1 I  GO  TO  24 

1121.3 

VALUTABt IX )-VALUTAB( IX )+COUNT«( ROWVALU**( 1 /COUNT) I 

1121 .4 

23 

COUNT  ~ 1 

1121.5 

GO  TO  25 

1121.6 

24 

VALUTAB< IX )=VALUTAB< IX )-( COUNT* ( ROWVALU**( 1 /COUNT ) ) ) 

1121.7 

GO  TO  23 

1122. 

22 

VALUTAB1  IX)=VALUTAB(  IX)*ROWVALU 

1123. 

25 

ROWVALU  =  0. 

1 124. 

RETURN 

1125. 

30 

CONTINUE 

1126. 

c — 

1127. 

c— 

NO  MATCHING  ROM  NAME  IN  NAMETAB.  (I.E.  ROMNAME  HAS  NOT 

1128. 

c— - 

BEEN  ENCOUNTERED  BEFORE  FOR  THIS  (OUTPUT)  COLUMN  NAME) 

1129. 

c— - 

1130. 

c— 

IF  TABLES  ARE  NOT  FULL, BRANCH  TO  "NEW  OUTPUT  TABLE  ENTRY' 

1131  . 

c-~ 

1132. 

40 

IF  ( LASTIX. LT.MAXENT)  GO  TO  50 

1133. 

c— 

1134. 

c — * 

OUTPUT  TA8LES  ARE  FULL. 

1135. 

c— 

PRINT  UARNING  AND  RETURN 

1136. 

c — 

1137. 

WRITE  (6,952)  MAXENT .COLNAME 

1138. 

952 

FORMAT! 1H  «*  NAMETAB/VALUTAB  DIMENSION, ' ,13, 

1139. 

1  ',  EXd'OED  FOR  COLUMN  ',8A1> 

1140. 

c— 

1141 . 

c— 

(THE  NUMBER  OF  SUCH  WARNING  MESSAGES  WILL  INDICATE  THE 

1142. 

c— 

EXTENT  OF  REOIMENSIONING  REQUIRED  -  DON'T  FORGET  TO 

1143. 

c — 

REOII1ENSION  IN  SUBROUTINE  COLOUT) 

1144. 

c — 

1145. 

RETURN 

1146. 

c — 

1147. 

c — 

NEW  OUTPUT  TABLE  ENTRY. 

1148. 

c— 

INCREMENT  LASTIX  (INDEX  OF  LAST  ENTRY) 

1149. 

c — 

INSERT  ROWNAME  IN  NAHETAB 

1150. 

c - 

INSERT  ROMVALU  IN  VALUTAB 

1151. 

c— 

RESET  ROMVALU  (FOR  SAFETY) 

1152. 

c — 

1153. 

50 

LASTIX  =  LASTIX  ♦  1 

1154. 

DO  60  L=1»8 

1 155. 

NAME TABt LASTIX,  L)  =  ROWNAME ( L) 

1156. 

60 

CONTINUE 

1156.1 

IF  ( ARITH )  GO  TO  70 

1156.2 

IF  (MINUS11  GO  TO  65 

1156.3 

VALUTABt  LASTIX  )=COUNT*< ROWVALU**( 1 /COUNT ) ) 

1156.4 

66 

COUNT  = 1 

1156.5 

GO  TO  80 

1156.6 

65 

VALUTAB( LASTIX )  =  (-1 )*< COUNT*! ROWVALU**(  1 /COUNT) )) 

1156.7 

GO  TO  66 

1157. 

70 

VALUTAS! LASTIX)  =  ROUVALU 

1158. 

80 

ROMVALU  =  0. 

1158.1 

IF  (GEOM)  GO  TO  81 

1158.11 

ARITH=TRUE 

1153.12 

GO  TO  82 

1158.2 

81 

ARITH=FALSE 

1159. 

82 

RETURN 

1160. 

END 

1161  . 

c — 

1 162. 

c — 

1163. 

c — 

1164. 

c - 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

1165. 

c— 

1166. 

c— 

1167. 

c— 

1168. 

C-— 

SUBROUTINE  COLOUT 

1169. 

c— 

1170. 

c— 

-  INPUT  LASTIX  (INDEX  OF  LAST  ENTRY  IN  OUTPUT  TABLES) 

1171  . 

c— 

(ASSUME  VALID  INDEX) 

1172. 

C-— 

-  PROCESSES  OUTPUT  TABLES  IN  COMMON  BLOCK2  TWO  ENTRIES 

1173. 

c — 

AT  A  TIME,  SUBMITTING  THEM  TO  SUBROUTINE  CARDOUT 

1174. 

c — 

FOR  OUTPUT 

1175. 

c — 

1176. 

SUBROUTINE  COLOUT! LASTIX) 

1177. 

c— 

1178. 

CHARACTER*)  TYFE( 4 ) ,COLNAME( 8 ) ,NAMETAB(100,8> .NAME1 (8) ,NAME2(8) 

1179. 

DIMENSION  VALUTAB(IOO) 

1180. 

COMMON/BLOCK2/COLNAME ,NAMETAB,VALUTAB,MAXENT 

1181. 

c — 

1182. 

c — 

COMMON  BLOCK 2  VARIABLES  - 

1183. 

c — 

(COLNAME  -  OUTPUT  NAME  OF  AGGREGATED  COLUMN) 

1184. 

c — 

(NAME TAB  -  LIST  OF  AGGREGATED  ROW  NAMES  ENCOUNTERED  FOR 

1185. 

c — 

THIS  COLUMN) 

1184. 

c— 

(VALUTAB  -  CORRESPONDING  LIST  OF  AGGREGATED  MPS  MATRIX  ENTRIES) 

1187. 

c— 

(MAXENT  -  MAXIMUM  HUMBER  ENTRIES  IN  NAMETAB/VALUTAB  ) 

1188. 

c— 

-  SHOULD  EQUAL  DIMENSION  ) 

1 1 89. 

1190. 

1191. 

1192. 

1193. 

1194. 

1195. 

1196. 

1197. 

1198. 

1199. 

1200. 
1201  . 
1202. 

1203. 

1204. 

1205. 

1206. 

1207. 

1208. 

1209. 

1210. 
1211 . 
<212. 

1213. 

1214. 

1215. 

1216. 

1217. 

1218. 

1219. 

1220. 
1221 . 
1222. 

1223. 

1224. 

1225. 

1226. 

1227. 

1228. 

1229. 

1230. 

1231 . 

1232. 

1233. 

1234. 

1235. 

1236. 

1237. 

1238. 

1239. 

1240. 


C — 

C -  INITIALIZE  TYPE  TO  BLANKS 

C— 

OATA  TYPE1 1 ) »TYPE<  2 ) iTYPEt  3) >TYPE(4)/'  V 

C — 

C -  COMPUTE  LEVEN  (LARGEST  EVEN  NUMBER  LESS  OR  EQUAL  TO  LASTIX)  ANO 

c—  NEVEN  (NUMBER  OF  EVEN  NUMBERS  LESS  OR  EQUAL  TO  LASTIX) 

C— 

NEVEN  =  LASTIX/2 
LEVEN  =  NEVEN*2 

c — 

C -  LOOP  OtICE  FOR  EVERY  TWO  ENTRIES  IN  OUTPUT  TABLES  (LOOP  OVER  I) 

c— 

IF  (NEVEN. EQ.O)  GO  TO  25 
00  20  1=1, NEVEN 
INDEX  =2*1-1 

c— 

c—  MOVE  NAMES  FROM  NAMETAB  INTO  NAME  1  ANO  NAME 2 

C—  (CALL  STATEMENT  MILL  NOT  ACCEPT  AN  IMPLIED  DO  LOOP) 

c— 

DO  10  J=< ,8 

NAME  I ( J )  =  NAMETAB( INDEX, J ) 

NAME2(J)  =  NAMETABI INDEX* 1 ,J) 

1 0  CONTINUE 

C— 

c—  OUTPUT  ONE  COLUMN  CARD  BY  CALLING  SUBROUTINE  CAPDOUT 

c— 

CALL  CAROOUT1 TYPE .COLNAME , 2 ,NAME1 , 

I  VALUTACI INDEX) ,NAME2,VALUTAB( INDEX+1 ) ) 

20  CONTINUE 

c— 

c—  IF  LASTIX  OOD,  OUTPUT  ONE  MORE  COLUMN  CARD  AND  RETURN 
C— 

25  IF  ( LAST IX. EQ. LEVEN)  RETURN 

DO  30  J=1 ,8 

NAME  1 ( J I  =  NAMETAB( LASTIX, J) 

NAMF2UI  =  NAMEKJ) 

30  CONTINUE 

CALL  CAROOUTt TYPE, COLNAME, 1 ,NAME2, 

1  VALUTAB1 LASTIX ) .NAME 2 , VALUTABt  LASTIX ) ) 

C— 

c—  (3-RD  ARGUMENT  IN  CALL  IS  NUMBER  OF  ROM  ENTRIES  SUBMITTED  FOR 
c—  OUTPUT  -  IN  THIS  CASE  ONLY  ONE  SO  6'TH  ANO  7-TH  ARGUMENTS 
C—  HILL  BE  IGNOREO) 

C— 

RETURN 

END 

C— 
c— 
c— 
c— 
c— 
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SUBROUTINE  CAROOUT 


124! . 

c— 

1242. 

C — 

1243. 

C— 

1244. 

c — 

1245. 

C— 

1246. 

c— 

1247. 

c— 

1248. 

c— 

1249. 

c — 

1250. 

c — 

1251 . 

c— 

1252. 

c— 

1253. 

c — 

1254. 

c — 

1255. 

c — 

1256. 

c— 

1257. 

c — 

1258. 

1259. 

1260. 

c— 

1261 . 

1262. 

c— 

1263. 

c— 

1264. 

c— 

1265. 

c— 

1266. 

c— 

1267. 

1268. 

1269. 

c - 

1270. 

C-— 

1271  . 

c— 

1272. 

1273. 

c— 

1274. 

c— 

1275. 

c— 

1276. 

1277. 

1278. 

1279. 

1280. 

954 

1281 . 

1282. 

c— 

1283. 

c— 

1284. 

c— 

1285. 

c— 

1286. 

5 

1287. 

1238. 

1289. 

1290. 

c — 

1291  . 

c— 

1292. 

c - 

-  INPUT  TYPE  (4  CHARACTER  (BOUND)  TYPE) 

COLNAME  (8  CHAR.  COLUMN/RHS/BOUND  NAME) 
NENTRY  (NUMBER  OF  ENTRIES  SUBMITTED 
FOR  OUTPUT  -  ASSUME  1  OR  2  ) 

NAME)  (6  CHAR.  NAME  OF  FIRST  ENTRY) 

VALUE!  (FIRST  ENTRY  VALUE) 

NAME 2  (8  CHAR.  NAME  OF  SECOND  ENTRY) 

VALUES  (SECOND  ENTRY  VALUE) 

-  PRINTS  WARNING  IF  ANY  VALUE  ENTRY  IS  ZERO 
(UNLESS  THIS  IS  A  BOUND  CARD) 

-  COUNTS  NUM3ER  OF  OIGITS  TO  LEFT  OF  OECIMAL 
FOR  EACH  VALUE  ENTRY 

-  SELECTS  APPROPRIATE  FORMAT  STATEMENT 

-  WRITES  OUT  ONE  CARD  AND  RETURNS 

SUBROUTINE  CARDOUH  TYPE  .COLNAME  .NENTRY, NAME1 .VALUE! .NAMES, 

I  VALUE2 ) 

CHARACTER*!  TYPE ( 4 ) .COLNAME 1 8 ) .NAME! ( 8) ,NAME2<  8) .BLANK 
INITIALIZE  BLANK 

THEN.  IF  INPUT  TYPE  FIELD  NOT  BLANK  (IE.  A  BOUND  CARD), 

BYPASS  TEST  FOR  ZERO  ENTRY 

DATA  BLANK/*  •/ 

IF  (TYPE(2).NE. BLANK)  GO  TO  5 

INITIALIZE  EPSILON  (TOLERANCE  FOR  ZERO) 

EPSILON  =  0.00000! 

IF  A  SUBMITTED  ENTRY  IS  WITHIN  EPSILON  OF  ZERO,  PRINT  WARNING 

IF  ( ABS( VALUE ! ).LT. EPSILON) 

1  WRITE  (6,954)  COLNAME .NAME! .VALUE! 

IF  (ABS1VALUE2). LT. EPSILON. AND. NENTRY. NE.l ) 

!  WRITE  (6,954)  COLNAME .NAMES .VALUES 
FORMAT  (1H  , 'COLUMN  NAME  ',8A1,*  ROW  NAME  ’.8A1,'  VALUE  *, 

!  F!S.6, *  **  ZERO  ENTRY' ) 

BRANCH  ON  ABSOLUTE  VALUE  OF  FIRST  ENTRY 
(LARGEST  NUMBER  ANTICIPATED  IS  9,999,999.999) 

IF  ( AB5< VALUE! ).LT. 10000. )  GO  TO  10 
IF  ( ABS( VALUE! ).LT. 100000. )  GO  TO  70 
IF  (ABSIVALUEl I.LT. 1000000. )  GO  TO  130 
GO  TO  190 


1293. 

c— 

1294. 

C  FIRST  ENTRY  IS  WITHIN  10,000.  OF  ZERO. 

1295. 

c— 

1296. 

c — 

IF  ONLY  ENTRY,  OUTPUT  AND  RETURN 

1297. 

c — 

1298. 

1 0 

IF  (NENTRY.NE.1 1  GO  TO  20 

1299. 

WRITE  (9,931)  TYPE, COLNAME .NAME 1 , VALUE  1 

1300. 

RETURN 

1301  . 

c— 

1302. 

c— 

BRANCH  ON  ABSOLUTE  VALUE  OF  SECOND  ENTRY 

1303. 

c— 

1304. 

20 

IF  ( ASS( VALUE2 ) . LT. 1 0000 . )  GO  TO  30 

1305. 

IF  (ABS(VALUE2).LT. 100000.)  GO  TO  40 

1306. 

IF  (APS(VALUE2).LT. 1000000.  )  GO  TO  50 

1307. 

GO  TO  60 

1308. 

c— 

1309. 

c— 

SECOND  ENTRY  IS  WITHIN  10,000  OF  ZERO. 

1310. 

c— 

OUTPUT  AND  RETURN 

1311. 

c— 

1312. 

30 

WRITE  (9,931)  TYPE, COLNAME, NAME1 ,VALUE1 ,NANE2 

1313. 

RETURN 

1314. 

c— 

1315. 

c— 

SECOND  ENTRY  IS  BETWEEN  10,000.  AND  100,000. 

1316. 

c— 

OUTPUT  AND  RETURN 

1317. 

c— 

1318. 

40 

WRITE  (9,932)  TYPE, COLNAME, NAME  1 .VALUE! .NAME2 

1319. 

RETURN 

1320. 

c— 

1321 . 

c— 

SECOND  ENTRY  IS  BETWEEN  100,000  AND  1,000,000 

1322. 

c — - 

OUTPUT  AND  RETURN 

1323. 

c— 

1324. 

50 

WRITE  (9,933)  TYPE .COLNAME .NAME1 .VALUE1 .NAME2 

1325. 

RETURN 

1326. 

c - 

1327. 

c— 

SECONO  ENTRY  IS  GREATER  OR  EQUAL  1,000,000. 

1328. 

c— 

OUTPUT  AND  RETURN 

1329. 

c— 

1330. 

60 

WRITE  (9,934)  TYPE .COLNAME ,NAME1 .VALUE! ,NAME2 

1331 . 

RETURN 

1332. 

c— 

1333. 

c— 

1334. 

c— 

1335. 

c— 

1336. 

C  FIRST  ENTRY  IS  BETWEEN  10,000  AND  100,000. 

1337. 

c— 

1338. 

c— 

IF  ONLY  ENTRY,  OUTPUT  AND  RETURN 

1339. 

c — 

1340. 

70 

IF  OIENTRY.NE.il  GO  TO  80 

1341 . 

WRITE  (9,935)  TYPE .COLNAME ,NAME1 .VALUE) 

1342. 

RETURN 

1343. 

c— 

1344. 

c— 

BRANCH  ON  ABSOLUTE  VALUE  OF  SECONO  ENTRY 

i 


1 

1345. 

C - 

1346. 

80 

IF  (ABS(VALU£2).LT. 10000.  1  GO  TO  90 

1347. 

IF  ( ABS(VALUE2).LT.1 00000.  )  GO  TO  100 

1 

1348. 

IF  (ABS( VALUE21.1T. 1000000. )  GO  TO  110 

1349. 

GO  TO  120 

1350. 

c— 

1351 . 

c— 

SECOND  ENTRY  IS  WITHIN  10.000  OF  ZERO. 

1352. 

c— 

OUTPUT  AND  RETURN 

1353. 

c— 

1354. 

90 

WRITE  (9,935)  TYPE .COLNAME >NAME1  .VALUE)  ,NAME2 > VALUE2 

1355. 

RETURN 

1356. 

c— 

4 

1357. 

c— 

SECOND  ENTRY  IS  BETWEEN  10,000.  AND  100,000. 

1358. 

c— 

OUTPUT  AND  RETURN 

1359. 

c- — 

1360. 

1 00 

WRITE  (9,936)  TYPE, COLNAME, NAME) , VALUE) .NAME2 

1361  . 

RETURN 

1362. 

c— 

1363. 

c— 

SECOND  ENTRY  IS  BETWEEN  100,000  AND  1,000,000 

1364. 

c— 

OU1PUT  AND  RETURN 

1365. 

c— 

1366. 

110 

WRITE  (9,937)  TYPE .COLNAME .NAME1 .VALUE) .NAME2 

1367. 

RETURN 

1368. 

c — 

1369. 

c— 

SECOND  ENTRY  IS  GREATER  OR  EQUAL  1,000,000. 

1370. 

c— 

OUTPUT  AND  RETURN 

1371 . 

c— 

1372. 

120 

WRITE  (9.938)  TYPE. COLNAME. NAME) .VALUEI .NANE2 

1373. 

RETURN 

1374. 

c - 

1375. 

c - 

1376. 

c— 

1377. 

c— 

1378. 

C  FIRST  ENTRY  IS  BETWEEN  100,000  AND  1,000,000. 

1379. 

c— 

1380. 

c— 

IF  ONLY  ENTRY,  OUTPUT  AND  RETURN 

1381. 

c— 

1382. 

130 

IF  (NENTRY.NE.l )  GO  TO  140 

1383. 

WRITE  (9,939)  TYPE .COLNAME ,NAME1 .VALUE! 

1384. 

RETURN 

1335. 

c— 

1386. 

c— 

BRANCH  ON  ABSOLUTE  VALUE  OF  SECOND  ENTRY 

1387. 

c— 

1388. 

140 

IF  (ABS( VALUE21.LT. 10000. )  GO  TO  150 

1389. 

IF  (ABS(VALUE2).LT. 100000.  )  GO  TO  160 

1390. 

IF  ( A3S(VALUE2).LT.1 000000. )  GO  TO  170 

1391 . 

GO  TO  180 

1392. 

c— 

1393. 

c — 

SECOND  ENTRY  IS  WITHIN  10,000  OF  ZERO. 

1394. 

c — 

OUTPUT  AND  RETURN 

1395. 

c — 

1396. 

ISO 

WRITE  (9,939)  TYPE .COLNAME , NAME! , VALUEI ,NAME2 

RETURN 


1397. 

1398. 

1399. 
1409. 

1401 . 

1402. 

1403. 

1404. 

1405. 

1406. 

1407. 

1408. 

1409. 

1410. 

1411 . 

1412. 

1413. 

1414. 

1415. 

1416. 

1417. 

1418. 

1419. 

1420. 
1421  . 

1422. 

1423. 

1424. 

1425. 

1426. 

1427. 

1428. 

1429. 

1430. 
1431  . 

1432. 

1433. 

1434. 

1435. 

1436. 

1437. 

1438. 

1439. 

1440. 
1441  . 

1442. 

1443. 

1444. 

1445. 

1446. 

1447. 

1448. 


C— 

C—  SECOND  ENTRY  IS  BETWEEN  10,000.  AND  100,000. 

C—  OUTPUT  AND  RETURN 
C — 

160  WRITE  (9,940)  TYPE , CO LNAME .NAME 1 >VALUE1 ,NAME2 >VALUE2 
RETURN 

C— 

C-—  SECOND  ENTRY  IS  BETWEEN  100,000  AND  1,000,000. 

C—  OUTPUT  AND  RETURN 

c— 

170  WRITE  (9,941)  TYPE .COLNAME ,NAME1 .VALUE1 ,NAME2 .VALUE2 
RETURN 

C — 

C -  SECOND  ENTRY  IS  GREATER  OR  EQUAL  1,000,000. 

C—  OUTPUT  AND  RETURN 
C — 

180  WRITE  (9,942)  TYPE .COLNAME >NAME1 ,VALUE1 ,NAME2 , VALUE2 
RETURN 

C — 

C - 

c - 

C-  — 

C  FIRST  ENTRY  IS  GREATER  OR  EQUAL  1,000,000. 

C— 

C-—  IF  ONLY  ENTRY,  OUTPUT  AND  RETURN 
C— 

190  IF  ( NENTRY.NE . 1 )  GO  TO  200 

WRITE  (9,944)  TYPE .COLNAME .NAME 1 .VALUE  1 
RETURN 

c— 

c—  BRANCH  ON  ABSOLUTE  VALUE  OF  SECOND  ENTRY 
C  — 

200  IF  ( ABS( VALUE2 ) . LT. 1 0000. )  GO  TO  210 
IF  ( ABS( VALUE 2 ).LT. 100000. )  GO  TO  220 
IF  (ABS( VALUEEJ.LT. 1000000.)  GO  TO  230 
GO  TO  240 

C— 

c—  SECOND  ENTRY  IS  WITHIN  10,000  OF  ZERO. 

C—  OUTPUT  AND  RETURN 
C— 

210  WRITE  (9,944)  TYPE .COLNAME .NAMEt .VALUE1 ,NAME2 .VALUE2 
RETURN 

C— 

c—  SECOND  ENTRY  IS  BETWEEN  10,000.  AND  100,000. 
c—  OUTPUT  AND  RETURN 

c— 

220  WRITE  (9,945)  TYPE .COLNAME .NAME! .VALUE1 ,NAME2 .VALUE2 
RETURN 

C— 

C—  SECOND  ENTRY  IS  BETWEEN  100,000  AND  1,000,000. 

C -  OUTPUT  AND  RETURN 


1449. 

c— 

1450. 

230 

WRITE  (9,946)  TYPE .COLNAME ,NAME1 .VALUE1 >NAME2 .VALUE2 

1451  . 

RETURN 

1452. 

c — 

1453. 

c — 

SECOND 

ENTFy  IS  GREATER  OR  EQUAL  1,000,000. 

1454. 

c — 

OUTPUT 

AND  RETURN 

1455. 

c— 

1456. 

240 

WRITE  (9,946)  TYPE  .COLNAME  ,NAME1  ,VALUE1  ,NA)1E2  ,VALUE2 

1457. 

RETURN 

1458. 

c — 

1459. 

c — 

FORMAT 

STATEMENTS 

1460. 

c - 

1461  . 

931 

FORMAT 

(4A1.8A1 ,2X,8A1,2X,F12.6,3X,8A1,2X,F12.6) 

1462. 

932 

FORMAT 

( 4A1 >8A1 ,2X,8A1 ,2X , FI  2 .6 , 3X.8A1 , 2X.F1 2 .5 ) 

1463. 

933 

FORMAT 

( 4A1 , 8A1 ,2X,8A1 ,2X.F1 2 .6 , 3X.8A1 , 2X.F 1 2 .4 ) 

1464. 

934 

FORMAT 

(4A1.8A1 ,2X,8A1 >2X, FI  2 . 6  >  3X.8A1 ,2X,F12.3> 

1465. 

935 

FORMAT 

(4A1.8A1 .2X.8A1 , 2X, FI  2 . 5,3X,8A1 ,2X,F12.6) 

1466. 

936 

FORMAT 

( 4A1 ,8A1 ,2X,8A1,2X,F12.5,3X,6AI ,2X,F12.5) 

1467. 

937 

FORMAT 

(4A1 , 8A1 ,2X,8A1 ,2X,F12.5,3X,8A1 ,2X,F12.4) 

1468. 

938 

FORMAT 

(4A1.8A1 , 2X,8A1 ,2X,F12.5,3X,8A1 ,2X,F12.3) 

1469. 

939 

FORMAT 

(4A1 , 6A1 ,2X,8A1 ,2X,F1 2 .4, 3X.8A1 , 2X,F1 2 .6 ) 

1470. 

940 

FORMAT 

( 4A1 ,8A1 ,2X,8A1 ,2X,F12.4,3X,8A1 ,2X,F12.5) 

1471  . 

941 

FORMAT 

(4A1 , 6A1 , 2X,8A1 ,2X ,F1 2 .4 ,3X,8A1 , 2X.F1 2 .4 ) 

1472. 

942 

FORMAT 

(4A1 , 8A1 ,2X,8A1 , 2X.F1 2 .4 ,3X,8A 1 .2X.F12.3) 

1473. 

943 

FORMAT 

(4A1 ,8A1 ,2X,8A1 ,2X,F1 2. 3, 3X.8A1 , 2X,F1 2 .6 ) 

1474. 

944 

FORMAT 

( 4A1 ,8A1 .2X.8A1 ,2X,F12.3,3X,8A1 ,2X,F12.5) 

1475. 

945 

FORMAT 

( 4A1 ,8A1 ,2X,8A1 ,2X,F12.3,3X,BAI ,2X,F12.4) 

1476. 

946 

FORMAT 

( 4A1 ,8A1 , 2X.8A1 ,2X,F12.3,3X,8A1 ,2X,F12.3) 

1477. 

END 

1478. 

c— 

1479. 

C— 

1480. 

c— 

1481  . 

c — 

1492. 

c — 

1483. 

c — * 

1484. 

SDATA 

1485. 

..1.. 

2. .3. .4 

.5.. 6.. 7.. 8. .9.10.11.12.13.14.15.16.17.18.19.20 

1486. 

1 

2  3  1 

1 

1487. 

4STOP 

1488. 

/* 

1489. 

/* 

